Boa tarde rapazes!
Sou novo por aqui, mas já consulto os posts há bastante tempo pra personalizar minhas planilhas.
Tenho uma macro grande que gera um conjunto de páginas impressas, e dentro desse código eu precisava adicionar uma função, que, caso no range D8:D263 da planilha LISTAGEM, estiver escrito a palavra "CUBAR", ao menos uma vez, a planilha ROMCUB fosse impressa.
Já tentei usar vários códigos, mas como tenho que colocar ele dentro de outra macro, tem algo que não está fechando.
O código que utilizo hoje:
Sub imprimeintervalocomdados()
Dim meuIntervalo As String
Dim LR As Long
Dim i As Long
Dim meuIntervalo2 As String
Dim LR2 As Long
Dim i2 As Long
If MsgBox("IMPRIMIR?", vbYesNo) = vbYes Then
If Worksheets("LISTAGEM").Range("C4").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("C5").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("C6").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("E5").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("E6").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
With ThisWorkbook
.Activate
With .Worksheets("IMPRESSAO")
.Activate
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To LR
If .Cells(i, "A").Value = "" And _
.Cells(i, "A").HasFormula And _
Not .Cells(i, "A").MergeCells Then
Exit For
End If
Next i
meuIntervalo = .Range("C" & i).Address
.PageSetup.PrintArea = "$A$1:" & meuIntervalo
.PrintOut
End With
End With
'Nova função seria aqui
With ThisWorkbook
.Activate
With .Worksheets("ROMANEIO")
.Activate
LR2 = .Cells(.Rows.Count, 1).End(xlUp).Row
For i2 = 1 To LR2
If .Cells(i2, "A").Value = "" And _
.Cells(i2, "A").HasFormula And _
Not .Cells(i2, "A").MergeCells Then
Exit For
End If
Next i2
meuIntervalo2 = .Range("I" & i2).Address
.PageSetup.PrintArea = "$B$1:" & meuIntervalo2
.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("ECTE")
.Activate
ActiveSheet.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM")
.Activate
End With
End With
End If
End Sub
E ali no meio precisava adicionar essa nova função, já tentei definindo variável para o range, usando if e else, já tentei com Do While e com For e Next, mas não consegui fazer funcionar.
Alguém consegue me ajudar? Muito obrigado.
Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E
Imprimir página se encontra palavra específica
Re: Imprimir página se encontra palavra específica
Opa!!!
Consegui fazer, usei o código abaixo no meio do outro acima:
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM") 'Ativa a planilha onde é feita a busca;
.Activate
LR3 = .Cells(.Rows.Count, 4).End(xlUp).Row 'Faz a busca na coluna D;
For i3 = 8 To LR3 'Começando a partir da linha 8, já que na linha 7 já tinha a mesma palavra como referência;
If Cells(i3, 4).Value = "CUBAR" Then
Worksheets("ROMCUB").Activate 'Ativa a planilha que será impressa;
ActiveSheet.PrintOut 'Imprime
End If
Next
End With
End With
Ficou assim completo e otimizado:
Sub imprimeintervalocomdados()
Dim meuIntervalo As String
Dim LR As Long
Dim i As Long
Dim meuIntervalo2 As String
Dim LR2 As Long
Dim i2 As Long
Dim meuIntervalo3 As String
Dim LR3 As Long
Dim i3 As Long
If MsgBox("IMPRIMIR?", vbYesNo) = vbYes Then
If Worksheets("LISTAGEM").Range("C4").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("C5").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("C6").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("E5").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("E6").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
With ThisWorkbook
.Activate
With .Worksheets("IMPRESSAO")
.Activate
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To LR
If .Cells(i, "A").Value = "" And _
.Cells(i, "A").HasFormula And _
Not .Cells(i, "A").MergeCells Then
Exit For
End If
Next i
meuIntervalo = .Range("C" & i).Address
.PageSetup.PrintArea = "$A$1:" & meuIntervalo
.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM")
.Activate
LR3 = .Cells(.Rows.Count, 4).End(xlUp).Row
For i3 = 8 To LR3
If Cells(i3, 4).Value = "CUBAR" Then
Worksheets("ROMCUB").Activate
ActiveSheet.PrintOut
End If
Next
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("ROMANEIO")
.Activate
LR2 = .Cells(.Rows.Count, 1).End(xlUp).Row
For i2 = 1 To LR2
If .Cells(i2, "A").Value = "" And _
.Cells(i2, "A").HasFormula And _
Not .Cells(i2, "A").MergeCells Then
Exit For
End If
Next i2
meuIntervalo2 = .Range("I" & i2).Address
.PageSetup.PrintArea = "$B$1:" & meuIntervalo2
.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("ECTE")
.Activate
ActiveSheet.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM")
.Activate
End With
End With
End If
End Sub
Até a próxima! Quando apertar corro pra cá de novo!
Consegui fazer, usei o código abaixo no meio do outro acima:
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM") 'Ativa a planilha onde é feita a busca;
.Activate
LR3 = .Cells(.Rows.Count, 4).End(xlUp).Row 'Faz a busca na coluna D;
For i3 = 8 To LR3 'Começando a partir da linha 8, já que na linha 7 já tinha a mesma palavra como referência;
If Cells(i3, 4).Value = "CUBAR" Then
Worksheets("ROMCUB").Activate 'Ativa a planilha que será impressa;
ActiveSheet.PrintOut 'Imprime
End If
Next
End With
End With
Ficou assim completo e otimizado:
Sub imprimeintervalocomdados()
Dim meuIntervalo As String
Dim LR As Long
Dim i As Long
Dim meuIntervalo2 As String
Dim LR2 As Long
Dim i2 As Long
Dim meuIntervalo3 As String
Dim LR3 As Long
Dim i3 As Long
If MsgBox("IMPRIMIR?", vbYesNo) = vbYes Then
If Worksheets("LISTAGEM").Range("C4").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("C5").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("C6").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("E5").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
If Worksheets("LISTAGEM").Range("E6").Value = "" Then
MsgBox "INFORMAÇÕES INCOMPLETAS!"
Exit Sub
End If
With ThisWorkbook
.Activate
With .Worksheets("IMPRESSAO")
.Activate
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To LR
If .Cells(i, "A").Value = "" And _
.Cells(i, "A").HasFormula And _
Not .Cells(i, "A").MergeCells Then
Exit For
End If
Next i
meuIntervalo = .Range("C" & i).Address
.PageSetup.PrintArea = "$A$1:" & meuIntervalo
.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM")
.Activate
LR3 = .Cells(.Rows.Count, 4).End(xlUp).Row
For i3 = 8 To LR3
If Cells(i3, 4).Value = "CUBAR" Then
Worksheets("ROMCUB").Activate
ActiveSheet.PrintOut
End If
Next
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("ROMANEIO")
.Activate
LR2 = .Cells(.Rows.Count, 1).End(xlUp).Row
For i2 = 1 To LR2
If .Cells(i2, "A").Value = "" And _
.Cells(i2, "A").HasFormula And _
Not .Cells(i2, "A").MergeCells Then
Exit For
End If
Next i2
meuIntervalo2 = .Range("I" & i2).Address
.PageSetup.PrintArea = "$B$1:" & meuIntervalo2
.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("ECTE")
.Activate
ActiveSheet.PrintOut
End With
End With
With ThisWorkbook
.Activate
With .Worksheets("LISTAGEM")
.Activate
End With
End With
End If
End Sub
Até a próxima! Quando apertar corro pra cá de novo!