¿Por que siempre en el listado de facturas cobradas aparecen las mismas facturas?
Tengo un archivo que en el listado de facturas cobradas siempre es el mismo, la facturas siempre son las mismas, no cambian; la rutina es la siguiente
Private Sub CommandButton7_Click()
'imprimir Cobrades
'listado "Cobrades", "A:C,M:M,K:K"
Application.ScreenUpdating = False
Set h1 = Sheets("Cobrades")
u = h1.Range("C" & Rows.Count).End(xlUp).Row
c = "C"
With h1.Sort
.SortFields.Clear: .SortFields.Add Key:=h1.Range(c & "2:" & c & u)
.SetRange h1.Range("A1:K" & u): .Header = xlYes: .Apply
End With
ant = h1.Cells(2, c)
Set h2 = Sheets("temporal")
h2.Cells.Clear
'ActiveSheet.Name = "grupo " & ant
h1.Rows(1).Copy h2.Rows(1)
h1.Rows(2).Copy h2.Rows(2)
j = 3
For i = 2 To u + 1
If ant <> h1.Cells(i, c) Then
h1.Rows(i).Copy h2.Rows(j)
j = j + 1
End If
ant = h1.Cells(i, c)
Next
h2.Columns("N:N").Delete Shift:=xlToLeft
h2.Columns("L:L").Delete Shift:=xlToLeft
h2.Columns("D:J").Delete Shift:=xlToLeft
h2.Columns("A:E").EntireColumn.AutoFit
h2.Columns("B:B").NumberFormat = "dd/mm/yy"
h2.Columns("E:E").NumberFormat = "#,##0.00 ""€"";[Red]#,##0.00 ""€"""
h2.Columns("C:C").ColumnWidth = 30
h2.Columns("D:D").ColumnWidth = 75
h2.Columns("E:E").ColumnWidth = 20
h2.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
h2.Range("A1:E1").Merge
h2.Range("A1") = "Llistat de " & h1.Name & " al " & Format(Date, "dd/mm/yyyy")
h2.Range("A1").HorizontalAlignment = xlCenter
With h2.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
h2.PrintPreview
Application.ScreenUpdating = True
End Sub
2 Respuestas
Este es el código para seleccionar el número de factura y después podrás imprimir solamente una factura.
Public hoja
Dim campo1
Private Sub CommandButton1_Click()
'
Me.Hide
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Activate()
'
Set h1 = Sheets("Inici")
Set h2 = Sheets(hoja)
campo1 = h1.[H8]
filtrar
End Sub
Private Sub filtrar()
'Por.DAM
'filtra los datos
Set t = Sheets("temporal")
t.Cells.Clear
Set h2 = Sheets(hoja)
With h2
m = "O" 'columna de consecutivo
u = .Range("C" & Rows.Count).End(xlUp).Row
.Range(m & "1") = 1
.Range(m & "2") = 2
If u > 2 Then _
.Range(m & "1:" & m & "2").AutoFill _
Destination:=.Range(m & "1:" & m & u), Type:=xlFillDefault
With .Range("A1:" & m & u)
If campo1 <> "" Then
.AutoFilter Field:=3, Criteria1:=campo1
.Copy t.Range("A1")
Else
Me.ListBox1 = ""
End If
End With
If .AutoFilterMode Then .Range("A1").AutoFilter
.Columns(m).ClearContents
ancho = Int(.Range("A1").Width + 5) & ";" & Int(.Range("B1").Width + 5) & ";" & _
Int(.Range("C1").Width + 5) & ";" & Int(.Range("D1").Width + 5) & ";" & _
Int(.Range("E1").Width + 5) & ";" & Int(.Range("F1").Width + 5) & ";" & _
Int(.Range("G1").Width + 5) & ";" & Int(.Range("H1").Width + 5) & ";" & _
Int(.Range("I1").Width + 5) & ";" & Int(.Range("J1").Width + 5) & ";" & _
Int(.Range("K1").Width + 5) & ";" & Int(.Range("L1").Width + 5) & ";" & _
Int(.Range("M1").Width + 5) & ";" & Int(.Range("N1").Width + 5) & ";" & _
0
End With
u = t.Range("C" & Rows.Count).End(xlUp).Row
If u > 1 Then
With Me.ListBox1
'.ColumnWidths = "50;50"
.ColumnCount = Columns(m).Column
.ColumnHeads = True
.ColumnWidths = ancho
.RowSource = t.Name & "!A2:" & m & u
End With
Else
MsgBox "No hay registros a mostrar"
Unload Me
End If
End SubTambién te anexo el código con algunos detalles.
Private Sub CommandButton7_Click()
'Por.DAM
'imprimir Cobrades
'listado "Cobrades", "A:C,M:M,K:K"
Application.ScreenUpdating = False
Set h1 = Sheets("Cobrades")
c = "A"
u = h1.Range(c & Rows.Count).End(xlUp).Row
With h1.Sort
.SortFields.Clear: .SortFields.Add Key:=h1.Range(c & "2:" & c & u)
.SetRange h1.Range("A1:K" & u): .Header = xlYes: .Apply
End With
ant = h1.Cells(2, c)
anc = h1.Cells(2, "C")
Set h2 = Sheets("temporal")
h2.Cells.Clear
'ActiveSheet.Name = "grupo " & ant
h1.Rows(1).Copy h2.Rows(1)
h1.Rows(2).Copy h2.Rows(2)
j = 3
For i = 2 To u + 1
If ant <> h1.Cells(i, c) Or anc <> h1.Cells(i, "C") Then
h1.Rows(i).Copy h2.Rows(j)
j = j + 1
End If
ant = h1.Cells(i, c)
anc = h1.Cells(i, "C")
Next
h2.Columns("N:N").Delete Shift:=xlToLeft
h2.Columns("L:L").Delete Shift:=xlToLeft
h2.Columns("D:J").Delete Shift:=xlToLeft
h2.Columns("A:E").EntireColumn.AutoFit
h2.Columns("B:B").NumberFormat = "dd/mm/yy"
h2.Columns("E:E").NumberFormat = "#,##0.00 ""€"";[Red]#,##0.00 ""€"""
h2.Columns("C:C").ColumnWidth = 30
h2.Columns("D:D").ColumnWidth = 75
h2.Columns("E:E").ColumnWidth = 20
h2.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
h2.Range("A1:E1").Merge
h2.Range("A1") = "Llistat de " & h1.Name & " al " & Format(Date, "dd/mm/yyyy")
With h2.Columns("E:E")
.Font.Name = "Verdana"
.Font.Size = 10
.HorizontalAlignment = xlRight
End With
h2.Range("E2").HorizontalAlignment = xlCenter
h2.Range("A1").HorizontalAlignment = xlCenter
With h2.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
h2.PrintPreview
Application.ScreenUpdating = True
End SubSaludos.Dante Amor
Vamos a revisar este tramo de tu código:
ant = h1.Cells(2, c)
Set h2 = Sheets("temporal")
h2.Cells.Clear
'ActiveSheet.Name = "grupo " & ant
h1.Rows(1).Copy h2.Rows(1)
h1.Rows(2).Copy h2.Rows(2) 'copia fila 2
j = 3
For i = 2 To u + 1
If ant <> h1.Cells(i, c) Then 'aquí son iguales cdo i=2
h1.Rows(i).Copy h2.Rows(j) 'copia nuevamente la fila 2 cdo i = 2
j = j + 1
End If
ant = h1.Cells(i, c)
Next
Comenta si esto está bien o necesitas que siga probando.