Este fórum está sendo desativado

[ICEFROG]

Boas, precisava da vossa ajuda perceber erro que não vi a estruturar o codigo.

O codigo funciona da seguinte forma, primeira sheet e para ser preenchido a segunda e para printar, a opcao e o dia de hoje ou amanha para serem cópiado.

Algo que quero introduzir no codigo que não tenho conseguido é fazer que seja detectado se algo foi filtrado para ser printado.

Por exemplo pode ser que o dia de amanha( ou hoje) não tenha data, sendo assim vai aparecer mensagem que nada vai ser printado porque não a nada deste dia.

Codigo que tenho trabalhado até o momento. Ajuda sugestões são bem vindas.

Código: Selecionar todos

Private Sub TEST1()

Dim rng1 As Range, rng2 As Range, rngMERGE1 As Range, rngMERGE2 As Range, rngMERGE3 As Range
Dim ques As String, Text1 As String, Text2 As String, Text3 As String


Text1 = "HEADER1"
Text2 = "HEADER2 " & Format(Date + 1, "dd/MM")
Text3 = "HEADER3"

Set rngMERGE1 = REC_TEST.Range("B1:E1")
Set rngMERGE2 = REC_TEST.Range("B2:J2")
Set rngMERGE3 = REC_TEST.Range("K2:O2")

Set rng1 = REC123.Range("B4:O" & REC123.Range("B" & Rows.Count).End(xlUp).Row)
Set rng2 = REC_TEST.Range("B3:O" & REC_TEST.Range("B" & Rows.Count).End(xlUp).Row)

REC_TEST.Cells.Clear


With rngMERGE1
    .Merge
    .Value = Text1
    .Font.Bold = True
    .Font.Name = "Calibri"
    .Font.Size = 15
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Interior.ColorIndex = 35
    .BorderAround , LineStyle:=xlContinuous, Weight:=xlThick
End With

With rngMERGE2
    .Merge
    .Value = Text2
    .Font.Bold = True
    .Font.Name = "Calibri"
    .Font.Size = 13
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Interior.ColorIndex = 40
    .BorderAround , LineStyle:=xlContinuous, Weight:=xlThick
End With

With rngMERGE3
    .Merge
    .Value = Text3
    .Font.Bold = True
    .Font.Name = "Calibri"
    .Font.Size = 13
    .WrapText = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Interior.ColorIndex = 50
    .BorderAround , LineStyle:=xlContinuous, Weight:=xlThick
End With


    ques = InputBox("selec dia? (1 hj, or 2 amanha)", "test", "1")
    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    ElseIf ques = "2" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    Else
        MsgBox "não corresponde"
        Exit Sub
    End If
    

REC_TEST.UsedRange.EntireRow.EntireColumn.AutoFit


rng1.AutoFilter 2
rng2.AutoFilter 6
End Sub

[osvaldomp]

substitua este trecho

Código: Selecionar todos

ques = InputBox("selec dia? (1 hj, or 2 amanha)", "test", "1")
    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    ElseIf ques = "2" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    Else
        MsgBox "não corresponde"
        Exit Sub
    End If

#
pelo trecho abaixo

Código: Selecionar todos

 ques = InputBox("selec dia? (1 hj, or 2 amanha)", "test", "1")
    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
    ElseIf ques = "2" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
    Else
        MsgBox "não corresponde"
        Exit Sub
    End If
    
    If Sheets("TEST1").AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 Then
     rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    Else: MsgBox "NÃO HÁ DADOS PARA PRINTAR"
    End If

#
dica - o seu código limpa a planilha TESTPASTE e em seguida torna a refazer o que foi apagado ; limpe somente os dados, a partir da linha 3, assim o seu código poderá ser reduzido à metade.

[ICEFROG]

substitua este trecho

Código: Selecionar todos

ques = InputBox("selec dia? (1 hj, or 2 amanha)", "test", "1")
    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    ElseIf ques = "2" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    Else
        MsgBox "não corresponde"
        Exit Sub
    End If

#
pelo trecho abaixo

Código: Selecionar todos

 ques = InputBox("selec dia? (1 hj, or 2 amanha)", "test", "1")
    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
    ElseIf ques = "2" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
    Else
        MsgBox "não corresponde"
        Exit Sub
    End If
    
    If Sheets("TEST1").AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 Then
     rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
    Else: MsgBox "NÃO HÁ DADOS PARA PRINTAR"
    End If

#
dica - o seu código limpa a planilha TESTPASTE e em seguida torna a refazer o que foi apagado ; limpe somente os dados, a partir da linha 3, assim o seu código poderá ser reduzido à metade.

Boas, sim faz sentido o que disseste, era para evitar a mensagem "a perguntar se queria substituir o conteúdo", ai meti logo tudo haha. quando tiver acesso ao ficheiro vou adicionar o código que fizeste. Obrigado.

[ICEFROG]

Boas, adicionei o codigo que fizeste, correu lindamente.

So tenho uma unica duvida, não sei se consegues resolver, quando faço o print, as vezes apanha a area setup correta ( maioria das vezes não, so quando mudo algo que apanha as vezes) outras não fiquei bem confuso não sei se passou algo que não me apercebi.

DIA_HEADER_1/2 e um sub para chamar o header antigo que fazia o merge.

Codigo que tenho ate o momento. Obrigado

Código: Selecionar todos

Private Sub TEST1()

Dim rng1 As Range, rng2 As Range
Dim ques
Dim wsm As Worksheet, wsmra As Worksheet
Dim lastrow As Long

Set wsm = Sheets("TEST1")
Set wsmra = Sheets("TESTPASTE")
    
Set rng1 = wsm.Range("B4:O" & wsm.Range("B" & Rows.Count).End(xlUp).Row)
Set rng2 = wsmra.Range("B3:O" & wsmra.Range("B" & Rows.Count).End(xlUp).Row)

lastrow = wsmra.UsedRange.Rows.Count

wsmra.Cells.Clear

    ques = InputBox("selec dia? (1 hj, or 2 amanha)", "test", "1")

    Application.ScreenUpdating = False
    
    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        DIA_HEADER_1
    ElseIf ques = "2" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues
        DIA_HEADER_2
    Else
        MsgBox "1 ou 2."
        Exit Sub
    End If
 
    If wsm.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 Then
        rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=rng2
        wsmra.UsedRange.EntireRow.EntireColumn.AutoFit
        wsmra.PageSetup.PrintArea = Range("A1:O" & lastrow).Rows.SpecialCells(xlCellTypeVisible).Address
        wsmra.PrintPreview
    Else
        MsgBox "Não há nada para este dia"
        Exit Sub
    End If
    
    Application.ScreenUpdating = True
    
rng1.AutoFilter 2
rng2.AutoFilter 5

End Sub

Ficheiro atualizado adicionado.

[osvaldomp]

Mude a posição da linha em vermelho da posição atual para a posição conforme indicado abaixo.

wsmra.UsedRange.EntireRow.EntireColumn.AutoFit
lastrow = wsmra.UsedRange.Rows.Count
wsmra.PageSetup.PrintArea = Range("A1:O" & lastrow).Rows.SpecialCells(xlCellTypeVisible).Address

[ICEFROG]

Mude a posição da linha em vermelho da posição atual para a posição conforme indicado abaixo.

wsmra.UsedRange.EntireRow.EntireColumn.AutoFit
lastrow = wsmra.UsedRange.Rows.Count
wsmra.PageSetup.PrintArea = Range("A1:O" & lastrow).Rows.SpecialCells(xlCellTypeVisible).Address

So agora consegui fazer alguns atualizações, o que estava acontecer era que eu filtrava rng1 apenas 2x, eram as 3, a terceira estava rng1 . porque ja estava a fazer o paste da sheet 1,

como estava :

Código: Selecionar todos

    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng2.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues

Correto:

Código: Selecionar todos

    If ques = "1" Then
        rng1.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rng1.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        rng1.AutoFilter 6, Criteria1:="TRUE2", Operator:=xlFilterValues

Obrigado ajudou bastante.