Notifications
Clear all

Gerador de etiquetas

2 Posts
2 Usuários
0 Reactions
1,277 Visualizações
(@souzadenilson)
Posts: 96
Estimable Member
Topic starter
 

Boa tarde
Solicito pequena ajuda no Gerador de Etiquetas.
Quando especifica 1 etiqueta, ela é colada nas colunas a,b,c, e quando solicita 2 etiquetas a segunda é colada nas colunas d,e ,f.
O ajuste necessário é quando solicita 3 ou mais etiquetas, a partir da 3º etiqueta as demais etiquetas ficam sobrepostas nas colunas d,e,f.
O que preciso, é que todas as etiquetas fiquem uma abaixo da outra, principalmente quando é solicitado acima de 2 etiquetas.

Segue a macro das etiquetas

Sub Retângulodecantosarredondados1_Clique()
'Sub Gera_Etiqueta()


Application.ScreenUpdating = False

Dim Codigo As String
Dim Lin As Integer
Dim U_L As Integer
Dim I As Integer
Dim Qtde As Integer
Dim Num As String
Dim Cor As String
Dim Loc As String
Dim Nome As String
Dim S As String ' sitema de corte
Dim Cod_Rastreio As String
Dim Col As Integer
Dim ik As Integer
Dim Receb As Date
Dim LOTE As Integer
Dim TESTE As String
Dim TESTE1 As String
Dim TESTE2 As String
Sheets("COD BARRAS").Activate 'GUIA "IMP"
    
    Sheets("COD BARRAS").DrawingObjects.Delete 'GUIA "IMP"
    U_L = Sheets("CAD BARRAS").Range("D" & Rows.Count).End(xlUp).Row 'GUIA "GERADOR"
    Lin = 1: Col = 1
    
    For I = 2 To U_L
        Nome = Sheets("CAD BARRAS").Range("a" & I) 'GUIA "GERADOR"
        Num = Sheets("CAD BARRAS").Range("b" & I)
        Cor = Sheets("CAD BARRAS").Range("c" & I)
        TESTE = Sheets("CAD BARRAS").Range("d" & I)
        Qtde = Sheets("CAD BARRAS").Range("e" & I)  'GUIA "GERADOR"
               
        
        Sheets("RESUMO").Activate               'GUIA "IDENTIFICACAO"
        Sheets("resumo").Range("B2") = Nome  'GUIA "IDENTIFICACAO"
        With Sheets("resumo").Range("B2")
           .Font.FontStyle = "regular"
           .Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        Sheets("resumo").Range("A3") = "Fab:" & Num
        With Sheets("resumo").Range("a3")
           .Font.FontStyle = "regular"
           '.Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        Sheets("resumo").Range("a4") = "Val:" & Cor
        With Sheets("resumo").Range("a4")
           .Font.FontStyle = "regular"
           '.Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        Sheets("RESUMO").Range("A5") = "Lote:" & TESTE
        With Sheets("resumo").Range("a5")
           .Font.FontStyle = "regular"
           '.Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        
        Sheets("resumo").Range("A1:C5").Copy    'GUIA "IDENTIFICACAO"
    
        Sheets("COD BARRAS").Activate                'GUIA "IMP"
        
        For ik = 1 To Qtde
        
       Sheets("COD BARRAS").Cells(Lin, Col).Select   'GUIA "IMP"
      ' Sheets("COD BARRAS").Cells(Lin, Col).Select        'GUIA "IMP"
       Sheets("COD BARRAS").Pictures.Paste              'GUIA "IMP"
            
            Col = Col + 3
            If Col = 6 Then
                Lin = Lin + 1
                Col = 1 '1
            End If
        Next ik
    Next I
    
    
'    For ik = 1 To Qtde
'
'       Sheets("COPIAS QUADROS").Cells(Lin, COL).Select     'GUIA "IMP"
'       'Sheets("COPIAS QUADROS").Cells(Lin, COL).Select        'GUIA "IMP"
'       Sheets("COPIAS QUADROS").Pictures.Paste              'GUIA "IMP"
'
'            COL = COL + 1
'            If COL = 4 Then
'                Lin = Lin + 1
'                COL = 1
'            End If
'        Next
'    Next
    
    
    
    
    
  Unload UserForm1
  
Application.ScreenUpdating = True

ActiveWindow.SelectedSheets.PrintPreview
'ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
'Sheets("CAD BARRAS").Select
'End Sub
End Sub

 
Postado : 29/01/2018 11:56 am
(@klarc28)
Posts: 971
Prominent Member
 

Acostume-se a executar o código passo a passo, apertando F8. Foi só mudar de 6 para 7.

Sub Retângulodecantosarredondados1_Clique()
'Sub Gera_Etiqueta()


Application.ScreenUpdating = False

Dim Codigo As String
Dim Lin As Integer
Dim U_L As Integer
Dim I As Integer
Dim Qtde As Integer
Dim Num As String
Dim Cor As String
Dim Loc As String
Dim Nome As String
Dim S As String ' sitema de corte
Dim Cod_Rastreio As String
Dim Col As Integer
Dim ik As Integer
Dim Receb As Date
Dim LOTE As Integer
Dim TESTE As String
Dim TESTE1 As String
Dim TESTE2 As String
Sheets("COD BARRAS").Activate 'GUIA "IMP"
    
    Sheets("COD BARRAS").DrawingObjects.Delete 'GUIA "IMP"
    U_L = Sheets("CAD BARRAS").Range("D" & Rows.Count).End(xlUp).Row 'GUIA "GERADOR"
    Lin = 1: Col = 1
    
    For I = 2 To U_L
        Nome = Sheets("CAD BARRAS").Range("a" & I) 'GUIA "GERADOR"
        Num = Sheets("CAD BARRAS").Range("b" & I)
        Cor = Sheets("CAD BARRAS").Range("c" & I)
        TESTE = Sheets("CAD BARRAS").Range("d" & I)
        Qtde = Sheets("CAD BARRAS").Range("e" & I)  'GUIA "GERADOR"
               
        
        Sheets("RESUMO").Activate               'GUIA "IDENTIFICACAO"
        Sheets("resumo").Range("B2") = Nome  'GUIA "IDENTIFICACAO"
        With Sheets("resumo").Range("B2")
           .Font.FontStyle = "regular"
           .Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        Sheets("resumo").Range("A3") = "Fab:" & Num
        With Sheets("resumo").Range("a3")
           .Font.FontStyle = "regular"
           '.Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        Sheets("resumo").Range("a4") = "Val:" & Cor
        With Sheets("resumo").Range("a4")
           .Font.FontStyle = "regular"
           '.Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        Sheets("RESUMO").Range("A5") = "Lote:" & TESTE
        With Sheets("resumo").Range("a5")
           .Font.FontStyle = "regular"
           '.Characters(1, InStr(.Value, ":")).Font.Bold = True
        End With
        
        Sheets("resumo").Range("A1:C5").Copy    'GUIA "IDENTIFICACAO"
    
        Sheets("COD BARRAS").Activate                'GUIA "IMP"
        
        For ik = 1 To Qtde
        
       Sheets("COD BARRAS").Cells(Lin, Col).Select   'GUIA "IMP"
      ' Sheets("COD BARRAS").Cells(Lin, Col).Select        'GUIA "IMP"
       Sheets("COD BARRAS").Pictures.Paste              'GUIA "IMP"
            
            Col = Col + 3
            If Col = 7 Then
                Lin = Lin + 1
                Col = 1 '1
            End If
        Next ik
    Next I
    
    
'    For ik = 1 To Qtde
'
'       Sheets("COPIAS QUADROS").Cells(Lin, COL).Select     'GUIA "IMP"
'       'Sheets("COPIAS QUADROS").Cells(Lin, COL).Select        'GUIA "IMP"
'       Sheets("COPIAS QUADROS").Pictures.Paste              'GUIA "IMP"
'
'            COL = COL + 1
'            If COL = 4 Then
'                Lin = Lin + 1
'                COL = 1
'            End If
'        Next
'    Next
    
    
    
    
    
    
  Unload UserForm1
  
Application.ScreenUpdating = True

ActiveWindow.SelectedSheets.PrintPreview
'ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
'Sheets("CAD BARRAS").Select
'End Sub
End Sub
 
Postado : 29/01/2018 2:40 pm