¿Organizar y sacar resumen de datos de una hoja a otra?

Saludos,

Estoy haciendo una macro que me saque un resumen de una hoja llamada "Cons.Ventas Por Proveedor" a una que se llama Resumen,

Con lo que he podido aprender sobre programación en VBA y con la ayuda de la grabadora de macros logre sacar un código que ordena los datos de la hoja "Cons.Ventas Por Proveedor" según mi necesidad luego insertar subtotales, de ahi devuelve a la hoja "Resumen" la cantidad y el valor total consolidados por sucursal y proveedor Hasta ahi bien, la macro realiza el proceso bien.

Utilice la función buscar para tener una ubicación de la fila en la columna que contiene la palabra Total. El problema que tengo es que el bucle que debería marcar el fin de la macro no funciona y la macro se sigue ejecutando devolviendo al final de la hoja "Resumen" datos que no corresponden. Probé con F8 la ejecución y encontré que la función buscar se sigue ejecutando por toda la hoja,

Si alguien pudiera Revisar el código o darme luces sobre otras formas de realizar esta tarea

Gracias por el apoyo

Dejo el código, pero si necesitan un archivo con el ejemplo lo tengo,

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
ActiveWorkbook.Worksheets("Cons. Vtas por proveedor").Sort.SortFields.Add Key _
:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
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

Saludos.
Luis_V26