Macro para agregar Etiquetas e Imprimir
Tengo una base de datos con varios clientes para imprimir sus direcciones, y me encuentro que en la primera Macro si coloco una cantidad por ej. 24 etiquetas todo funciona normalmente o sea que al imprimir las hojas mantienen los márgenes de impresión.
Ahora si en la segunda Macro que es "Agregar Etiquetas" por ej. Tengo 6 etiquetas para 1 cliente y 10 para el segundo cliente, al ir para imprimir no me respeta los márgenes de impresión y en este caso de originar 2 hojas genera 3 (cada Hojas son de 8 etiquetas por hoja)
1 macro
Private Sub botSacarEt_Click()
Application.ScreenUpdating = False
Sheets("ETIQUETAS_IMPRESIONES").Select
ActiveSheet.ResetAllPageBreaks
ActiveSheet.PageSetup.PrintArea = ""
[B2:C5,B7:C8,B10:C11] = ""
If Me.ETIQUETAS = 0 Or Me.ETIQUETAS = "" Then
MsgBox "Debe elegir cuántas etiquetas crear"
Me.ETIQUETAS.SetFocus
Exit Sub
End If
[b2] = NOMBRE
[b3] = CUIT
[C3] = TELEFONO
[b4] = DIRECCION
[b5] = LOCALIDAD
[b7] = NOMBRE1
[b8] = DNI
[b10] = TRANSPORTE
[c10] = CANTIDAD
'COLOCO EL TAMAÑO DE LAS FILAS COMO EN LA ETIQUETA PRINCIPAL.
Rows("13:" & Rows.Count).RowHeight = 17
'COPIO Y PEGO LA ETIQUETA EN LOS SITIOS QUE LES CORRESPONDE
num = CDbl(ETIQUETAS)
If num Mod 2 = 0 Then
Range("A1:C12").Copy
Rows(13).RowHeight = 11
f = 14
For i = 1 To num / 2
Cells(f, 1).PasteSpecial xlPasteAll
Cells(f, 5).PasteSpecial xlPasteAll
Rows(f + 11).RowHeight = 11
f = f + 12
Next
Else
f = 14
For j = 1 To Int(num / 2)
Cells(f, 1).PasteSpecial xlPasteAll
Cells(f, 5).PasteSpecial xlPasteAll
'Rows(f & ":" & f + 10).RowHeight = 18
f = f + 12
Next j
End If
uf = Range("B" & Rows.Count).End(xlUp).Row + 1
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(61, 1)
ActiveSheet.PageSetup.PrintArea = Range("A14:G" & uf).Address
Application.ScreenUpdating = True
NOMBRE = Empty
CUIT = Empty
TELEFONO = Empty
DIRECCION = Empty
LOCALIDAD = Empty
TRANSPORTE = Empty
CANTIDAD = Empty
ETIQUETAS = Empty
Me.CommandButton3.Enabled = True
FormBotones.Show
End Sub
---------------------------------------------------------------------------------------
2 MACRO
Private Sub CommandButton3_Click()
Dim i%, j%
Dim etiq As Range
Dim ufa&, ufb&, ufi&
Application.DisplayAlerts = False
Sheets("ETIQUETAS_IMPRESIONES").Select
ufa = Range("C" & Rows.Count).End(xlUp).Row + 1
ufb = Range("G" & Rows.Count).End(xlUp).Row + 1
If ufa = ufb Then
If Me.ETIQUETAS = 0 Or Me.ETIQUETAS = "" Then
MsgBox "Debe eliegir cuántas etiquetas crear"
Me.ETIQUETAS.SetFocus
Exit Sub
End If
num = CDbl(ETIQUETAS)
[b2] = NOMBRE
[b3] = CUIT
[C3] = TELEFONO
[b4] = DIRECCION
[b5] = LOCALIDAD
[b7] = NOMBRE1
[b8] = DNI
[b10] = TRANSPORTE
[c10] = CANTIDAD
Set etiq = Range("A1:C12")
etiq.Copy
If num Mod 2 = 0 Then
f = ufa + 2
For i = 1 To num / 2
Cells(f, 1).PasteSpecial xlPasteAll
Cells(f, 5).PasteSpecial xlPasteAll
f = f + 12
Next i
Else
f = ufa + 2
For j = 1 To Int(num / 2)
Cells(f, 1).PasteSpecial xlPasteAll
Cells(f, 5).PasteSpecial xlPasteAll
f = f + 12
Next j
Cells(f, 1).PasteSpecial xlPasteAll
End If
Else
If Me.ETIQUETAS = 0 Or Me.ETIQUETAS = "" Then
MsgBox "Debe eliegir cuántas etiquetas crear"
Me.ETIQUETAS.SetFocus
Exit Sub
End If
num = CDbl(ETIQUETAS)
[b2] = NOMBRE
[b3] = CUIT
[C3] = TELEFONO
[b4] = DIRECCION
[b5] = LOCALIDAD
[b7] = NOMBRE1
[b8] = DNI
[b10] = TRANSPORTE
[c10] = CANTIDAD
Set etiq = Range("A1:C12")
etiq.Copy
Cells(ufb + 2, 5).PasteSpecial xlPasteAll
If num Mod 2 = 0 Then
f = ufa + 2
For i = 1 To num / 2
Cells(f, 1).PasteSpecial xlPasteAll
Cells(f, 5).PasteSpecial xlPasteAll
f = f + 12
Next i
Else
f = ufa + 2
For j = 1 To Int(num / 2)
Cells(f, 1).PasteSpecial xlPasteAll
Cells(f, 5).PasteSpecial xlPasteAll
f = f + 12
Next j
End If
End If
ufi = Range("B" & Rows.Count).End(xlUp).Row + 1
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(61, 1)
ActiveSheet.PageSetup.PrintArea = Range("A14:G" & ufi).Address
'impr = MsgBox("¿Desea imprimir las etiquetas?", vbYesNo, "Impresión de Etiquetas")
'If impr = vbYes Then
'ActiveWindow.SelectedSheets.PrintOut Copies:=1
'End If
Application.DisplayAlerts = True
Me.botSacarEt = False
NOMBRE = Empty
CUIT = Empty
TELEFONO = Empty
DIRECCION = Empty
LOCALIDAD = Empty
TRANSPORTE = Empty
CANTIDAD = Empty
ETIQUETAS = Empty
FormBotones.Show
End Sub
