Excel Macro de Inserir Conjunto de Dados pela Célula Quantidade

Leandro Mariano · 14 de dezembro de 2020

Olá pessoal, estou fazendo um programa que ira gerar uma quantidade de tabelas pré definidas, conforme a quantidade de vezes que eu colocar em uma célula.

ou seja em uma pasta MENU terá uma orientação - digite a quantidade de tabelas. na célula célula B3 o usuario digita exemplo = 200

Na pasta PADRÃO, temos duas tabelas que devem ser copiadas RANGE ( A1 até K7) e essas linhas devem ser copiadas e inserir celulas copiadas acima delas ou seja

Inserir acima A1

Essa operação deve ser feita conforme o input de valores na célula B3 da pasta MENU.

Eu cheguei nesta macro

Sub Gerador()
'
' Gerador Macro
'

'
Sheets("DADOS").Select
Sheets("PADRÃO").Visible = True
Sheets("PADRÃO").Select
Sheets("PADRÃO").Copy Before:=Sheets(2)
Sheets("PADRÃO").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("PADRÃO (2)").Select
Rows("2:8").Select
Selection.Copy
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Rows("2:2").Select
ActiveWindow.SmallScroll Down:=-12
Range("G2:J7").Select
Range("J2").Activate
Application.CutCopyMode = False
ActiveSheet.PageSetup.PrintArea = _
"$G$16:$J$21,$B$16:$E$21,$G$9:$J$14,$B$9:$E$14,$G$2:$J$7"
Range("B2:E7").Select
Range("E2").Activate
ActiveSheet.PageSetup.PrintArea = _
"$G$16:$J$21,$B$16:$E$21,$G$9:$J$14,$B$9:$E$14,$G$2:$J$7,$B$2:$E$7"
Range("A1").Select
End Sub

porém ela so executa o copy-paste uma vez.

Alguem poderia me ajudar.

Recorrer impressão rev03.xlsx

AfonsoMira · 15 de dezembro de 2020

Boas tudo bem.

Estive a estudar o seu caso e apenas consegui chegar nesta solução.

Ela imprimi o número de etiquetas que inserir, porêm tem que ser sempre número par de etiquetas.

Outro erro que não consigo resolver é quanto a questão da Area de impressão.

Até 20 etiquetas ele seta a area de impressão individualmente em cada etiqueta.

Mas caso sejam mais ele não faz isso, se álguem ai quiser alterar o meu código para resolver essa questão fique à vontade.

Código:

Sub Gerador()

Dim quantidade As Long
Dim i As Long
Dim linhas As Integer
Dim x As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Apaga planilha ETIQUETAS se existir
On Error Resume Next
Sheets("ETIQUETAS").Delete

'Seleciona Menu e vai buscar a quantidade de etiquetas
Sheets("MENU").Select
quantidade = Sheets("MENU").Range("F20")

'Torna planilha "PADRÃO" visivel, copia, cola e altera nome para "ETIQUETAS"
Sheets("DADOS").Select
Sheets("PADRÃO").Visible = True
Sheets("PADRÃO").Select
Sheets("PADRÃO").Copy Before:=Sheets(2)
Sheets("PADRÃO").Visible = False
Sheets("PADRÃO (2)").Name = "ETIQUETAS"


'Copia as células para criar as etiquetas
For i = 6 To quantidade Step 2

    Rows("2:8").Select
    Selection.Copy
    Rows("2:2").Select
    Selection.Insert Shift:=xlDown
    Rows("2:2").Select
    ActiveWindow.SmallScroll Down:=-12
    Range("G2:J7").Select
    Range("J2").Activate
    Application.CutCopyMode = False

Next i

linhas = quantidade / 2

linhas = linhas * 7

'Seleciona o range para colocar na print area, não sei o porque mas a partir de 20 etiquetas ele não seta o range
For x = 2 To linhas Step 7

    myRange = myRange & "$B$" & x & ":$E$" & x + 5 & "," & "$G$" & x & ":$J$" & x + 5 & ","

Next x

myRange = Left(myRange, Len(myRange) - 1)

Sheets("ETIQUETAS").PageSetup.PrintArea = ""

Sheets("ETIQUETAS").PageSetup.PrintArea = myRange

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Etiquetas geradas com sucesso!"
    
End Sub