Resumen de Datos, Ideas para Salir de un bucle Código:

Código:

Son dos macros, La primera prepara la hoja Resumen

Sub HojaResumen()
'Application.ScreenUpdating = False
'Workbooks("Ejemplo Hoja Resumen IG.xlsx").Activate
Worksheets("Resumen").Activate
Range("F1:G1").Select
Selection.Merge
ActiveCell.FormulaR1C1 = "ENTRADAS"
Range("H1:I1").Select
Selection.Merge
ActiveCell.FormulaR1C1 = "SALIDAS"
Range("A2").Value = "DOCUMENTO"
Columns("A:A").ColumnWidth = 14
Range("B2").Value = "SUCURSAL"
Columns("B:B").ColumnWidth = 27
Range("C2").Value = "PROVEEDOR"
Columns("C:C").ColumnWidth = 41
Range("D2").Value = "TIPO INVENTARIO"
Columns("D:D").ColumnWidth = 14
Range("E2").Value = "CLASIFICACIÓN"
Columns("E:E").ColumnWidth = 17
Range("F2").Value = "CANTIDAD"
Columns("F:F").ColumnWidth = 12
Range("G2").Value = "VR TOTAL"
Columns("G:G").ColumnWidth = 14
Range("H2").Value = "CANTIDAD"
Columns("H:H").ColumnWidth = 12
Range("I2").Value = "VR TOTAL"
Columns("I:I").ColumnWidth = 14
Rows("1:2").Select
Selection.Font.Bold = True
With Selection
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Call ResumenInventario
Worksheets("Resumen").Activate
Call FilaDocumentoVentas
Range("C3").Select
ActiveWindow.FreezePanes = True
'Application.ScreenUpdating = True
End Sub

La segunda Realiza el resumen

Option Explicit
Sub ResumenInventario()
'Application.ScreenUpdating = False
Application.CutCopyMode = False
Worksheets("Cons. Vtas por proveedor").Activate
ActiveWorkbook.Worksheets("Cons. Vtas por proveedor").Sort.SortFields.Add Key _
:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
'Selection.Sort Key1:=Range("d1"), Order1:=xlAscending, Header:=xlGuess, _
'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWorkbook.Worksheets("Cons. Vtas por proveedor").Sort.SortFields.Add Key _
:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
'Selection.Sort Key1:=Range("a1"), Order1:=xlAscending, Header:=xlGuess, _
'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("a1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 7), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Range("D10000").End(xlUp).Offset(1, 0).Value = "1"
Worksheets("Resumen").Activate
Range("B3").Select
Worksheets("Cons. Vtas por proveedor").Activate
Range("d1").Select
Do While ActiveCell.Value <> "1"
Application.CutCopyMode = False
Cells.Find(What:="Total", After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ActiveCell.Offset(-1, -3).Select
Selection.Copy
Worksheets("Resumen").Activate
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Select
Worksheets("Cons. Vtas por proveedor").Activate
ActiveCell.Offset(0, 3).Select
Selection.Copy
Worksheets("Resumen").Activate
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Select
Worksheets("Cons. Vtas por proveedor").Activate
ActiveCell.Offset(0, 8).Select
Selection.Copy
Worksheets("Resumen").Activate
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Select
Worksheets("Cons. Vtas por proveedor").Activate
ActiveCell.Offset(0, 1).Select
Selection.Copy
Worksheets("Resumen").Activate
ActiveSheet.Paste
Worksheets("Cons. Vtas por proveedor").Activate
ActiveCell.Offset(1, -6).Select
Selection.Copy
Worksheets("Resumen").Activate
ActiveCell.Offset(0, 4).Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(0, -1).Select
Worksheets("Cons. Vtas por proveedor").Activate
ActiveCell.Offset(0, -2).Select
Selection.Copy
ActiveCell.Offset(0, -1).Select
Worksheets("Resumen").Activate
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, -6).Select
Worksheets("Cons. Vtas por proveedor").Activate
Loop
'Range("a:n").Select
'Selection.RemoveSubtotal
'Range("A1").Select
'Application.ScreenUpdating = True
End Sub
Sub FilaDocumentoVentas()
Worksheets("Resumen").Activate
'Range("b10000").End(xlUp).Offset(1, 0).Value = ""
Range("b3").Select
Do While ActiveCell.Value <> ""
If ActiveCell.Value <> "" Then
ActiveCell.Offset(0, -1).Value = "VENTAS"
ActiveCell.Offset(1, 0).Select
End If
Loop
Range("b10000").End(xlUp).Offset(1, 0).Value = ""
End Sub