Guru do Excel e Power BI

Fórum de Dúvidas sobre Excel e Power BI
https://gurudoexcel.com/

VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

https://gurudoexcel.com/viewtopic.php?t=17122

Página 1 de 1

VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

Enviado: 19 Mai 2022 às 09:20
por 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

Re: VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

Enviado: 19 Mai 2022 às 12:21
por 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 :o ; limpe somente os dados, a partir da linha 3, assim o seu código poderá ser reduzido à metade. ;)

Re: VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

Enviado: 19 Mai 2022 às 18:45
por ICEFROG
osvaldomp escreveu: ↑19 Mai 2022 às 12:21 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 :o ; 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.

Re: VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

Enviado: 20 Mai 2022 às 08:52
por 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.

Re: VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

Enviado: 20 Mai 2022 às 10:21
por 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

Re: VBA Copiar/colar "Tabela" para outra sheet com base na escolha do dia e printar.

Enviado: 22 Mai 2022 às 18:50
por ICEFROG
osvaldomp escreveu: ↑20 Mai 2022 às 10:21 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, :lol:

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.
Todos os horários são UTC-03:00
Página 1 de 1
Powered by phpBB® Forum Software © phpBB Limited