¿Cómo modificar código VB para imprimir todos o solo los registros seleccionados de un listbox a un formato prestablecido?(DAM)
Dante Amor, hacia mucho tiempo que no visitaba este gran foro de ayuda y me da mucho gusto saber que ya esta de nuevo por aquí, casualmente la ayuda que requiero tiene que ver con una macro de su autoría, que tiene como objetivo seleccionar todos los registros del listbox para enviarlos a un formato e imprimirlos, sin embargo, ahora tengo la necesidad de contar con una opción que me permita seleccionar solo algunos de los registros para imprimirlos, recurro a su amplia experiencia para modificar dicha macro o contar con un nuevo botón que me permita realizar lo anterior.
También me gustaría pedirle de favor que me ayudará a corregir un error que tengo a la hora de enviar a impresión los registros del código 72932, hasta aquí todo bien, pero al intentar enviar una impresión de los registros de otro código; me marca un error que dice "No hay celdas disponibles...". Gracias de antemano por su atención. Saludos cordiales!
Comparto link del archivo:
1 Respuesta
Hola Dante Amor, aquí tienes el código del optionbutton para seleccionar todos los registros del listbox y el código del botón para imprimir.
No me lo has pedido, pero con la finalidad de que lo puedas observar mejor, me tomé la libertad de enviarte mi archivo completo a tu correo, en el asunto escribí el nombre de mi pregunta. Gracias por tu tiempo.
Private Sub OptionButton1_Click()
'Por.DAM
For i = 0 To ListBox1.ListCount - 1
ListBox1.Selected(i) = True
Next
End Sub
Private Sub CommandButton1_Click()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("FORMATO")
Set h2 = Sheets("IMPRESION")
Set h3 = Sheets("temp")
h2.Cells.Clear
h3.Cells.Clear
h3.Cells.UnMerge
h2.DrawingObjects.Delete
h2.Cells.Rows.RowHeight = 15
h2.ResetAllPageBreaks
h1.Rows("1:14").Copy h2.Range("A1")
h2.[B4] = TextBox4
h2.[B6] = TextBox6
h2.[B8] = TextBox13
h2.[B10] = TextBox5
h2.[B12] = TextBox2
h2.[H4] = TextBox1
h2.[H6] = TextBox3
h2.[H12] = TextBox14
j = 2
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
h3.Cells(j, "J") = ListBox1.List(i, 0)
h3.Cells(j, "K") = ListBox1.List(i, 1)
h3.Cells(j, "L") = ListBox1.List(i, 5)
j = j + 1
n = n + 1
End If
Next
u = h3.Range("J" & Rows.Count).End(xlUp).Row
h3.Range("J1:L1") = Array("A", "B", "C")
h3.Range("J1:J" & u).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=h3.Range("M1"), Unique:=True
u = h3.Range("J" & Rows.Count).End(xlUp).Row
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:="temp!R1C10:R" & u & "C12", _
Version:=xlPivotTableVersion12).CreatePivotTable _
TableDestination:="temp!R5C14", TableName:="Tabla dinámica2", _
DefaultVersion:=xlPivotTableVersion12
With h3.PivotTables("Tabla dinámica2").PivotFields("A")
.Orientation = xlRowField
.Position = 1
End With
With h3.PivotTables("Tabla dinámica2").PivotFields("B")
.Orientation = xlRowField
.Position = 2
End With
h3.PivotTables("Tabla dinámica2").AddDataField _
h3.PivotTables("Tabla dinámica2").PivotFields("C"), "Cuenta de C", xlCount
With h3.PivotTables("Tabla dinámica2")
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With
h3.PivotTables("Tabla dinámica2").PivotFields("A").Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
u = h3.Range("N" & Rows.Count).End(xlUp).Row - 1
h3.Range("N6:P" & u).Copy
h3.Range("S1").PasteSpecial Paste:=xlPasteValues
u = h3.Range("S" & Rows.Count).End(xlUp).Row
h3.Range("S2:S" & u).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
h3.Columns("S:S").Copy
h3.Range("S1").PasteSpecial Paste:=xlPasteValues
'u2 = h3.Range("M" & Rows.Count).End(xlUp).Row
'h3.Range("N2").FormulaR1C1 = "=VLOOKUP(RC[-1],C[-4]:C[-3],2,0)"
'h3.Range("O2").FormulaR1C1 = "=SUMIF(C[-5],RC[-2],C[-3])"
'h3.Range("N2:O2").AutoFill Destination:=h3.Range("N2:O" & u2)
'Calculate
h3.Columns("S").Copy
h3.Range("B1").PasteSpecial Paste:=xlValues
h3.Columns("T").Copy
h3.Range("G1").PasteSpecial Paste:=xlValues
h3.Columns("U").Copy
h3.Range("H1").PasteSpecial Paste:=xlValues
h3.Columns("B").EntireColumn.ColumnWidth = 10.71
h3.Columns("C").EntireColumn.ColumnWidth = 10.71
h3.Columns("D").EntireColumn.ColumnWidth = 10.71
h3.Columns("E").EntireColumn.ColumnWidth = 10.71
h3.Columns("F").EntireColumn.ColumnWidth = 15.43
h3.Columns("J:U").Clear
With h3.Columns("B").Font
.Name = "Arial"
.Size = 8
End With
h2.Columns("A").VerticalAlignment = xlTop
h3.Columns("A:H").VerticalAlignment = xlTop
For n = 1 To h3.Range("B" & i & ":F" & i).Columns.Count
sngAnchoTotal = sngAnchoTotal + h3.Range("B" & i & ":F" & i).Cells(1, n).ColumnWidth
Next n
For i = 2 To h3.Range("B" & Rows.Count).End(xlUp).Row
ajustarfila h3.Range("B" & i & ":F" & i), sngAnchoTotal
Next
Application.ScreenUpdating = True
j = 14
altohoja = 1
n = 1
arr = 668.25
For i = 2 To h3.Range("B" & Rows.Count).End(xlUp).Row
j = j + 1
sigalto = h3.Rows(i + 1).Top - h3.Rows(i).Top
If h2.Cells(j, "A").Top + sigalto >= arr Then
altohoja = altohoja + 49
sig = j
Do While h2.Cells(sig, "A").Top <= arr
sig = sig + 1
Loop
With h2.Range("A" & j & ":A" & sig)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
With h2.Range("G" & j & ":G" & sig)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
With h2.Range("H" & j & ":H" & sig)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
h1.Rows("45:49").Copy h2.Range("A" & sig)
h2.Rows("1:14").Copy h2.Range("A" & sig + 5)
j = sig + 5 + 14
arr = arr + 668.25 + 70.5
End If
h3.Rows(i).Copy h2.Rows(j)
With h2.Range("A" & j & ":A" & j)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
With h2.Range("G" & j & ":G" & j)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
With h2.Range("H" & j & ":H" & j)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
h2.Cells(j, "A") = n
n = n + 1
Next
sig = j
Do While h2.Cells(sig, "A").Top < arr
sig = sig + 1
Loop
With h2.Range("A" & j & ":A" & sig)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
With h2.Range("G" & j & ":G" & sig)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
With h2.Range("H" & j & ":H" & sig)
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
h1.Rows("45:49").Copy h2.Range("A" & sig)
E_SOLICITADO.Hide
h2.PrintPreview
E_SOLICITADO.Show
End Sub
Okay, a cabo de leer mi correo y he tomado nota. Estaré al pendiente de su respuesta en este foro, gracias.
A qué te refieres con:
Ahora tengo la necesidad de contar con una opción que me permita seleccionar solo algunos de los registros para imprimirlos
Si tienes la propiedad multiselect en el listbox, entonces puedes seleccionar uno a uno los registros que desees.
Nota: En lo sucesivo procura poner el código utilizando el icono para inserta código.
Tiene razón!, entonces no es necesario modificar ni agregar otro botón, sin embargo, el problema para imprimir persiste, pues cuando realizo una prueba de consulta por primera vez, la macro funciona bien, sin embargo, al intentar imprimir todos los registros por segunda ocasión o cuando intento imprimir solo uno o dos registros me aparecen esto dos errores:
Cambia esta línea:
h3.Range("S2:S" & u).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"Por estas líneas:
On Error Resume Next
h3.Range("S2:S" & u).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
Problema resuelto.
Haré una nueva consulta relacionada con esta BD para la conexión y vinculación de un Excel a otro. Mientras tanto, gracias por su apoyo, que tenga un esplendido Jueves.
Encantado de ayudarte, gra cias por comentar.
Solución:
On Error Resume Next
h3.Range("S2:S" & u).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
