Crear un consecutivo de una macro existente

Solicito de su ayuda por favor si alguien sabe y me puede colaborar con un consecutivo para una macro ya existente porque el que tengo no me da una secuencia lógica por la hojas creadas adjunto el código haber si alguien me puede colaborar,

Las partes que están en negrita son las que no he podido configurar para realizar el consecutivo.

Sub CORRER_REPORTE()
suma = 0
i = 7
j = 15
k = 2
y = 12
t = 1
m = 2
b = 1
g = 1
r = 12
bulean = 0
Sheets("Base").Select
ActiveWorkbook.Worksheets("Base").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Base").Sort.SortFields.Add Key:=Range("C8:C9999") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Base").Sort.SortFields.Add Key:=Range("B8:B9999") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Base").Sort
.SetRange Range("B7:CZ9999")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Do Until Cells(i, j) = "DEPO"
cv = Cells(i, j)
i = i + 1
Do Until Cells(i, j) = ""
If Cells(i, j) <> 0 Then
vector_codigo(g) = Cells(i, k)
vector_fab(g) = Cells(i, k + 1)
vector_color(g) = Cells(i, k + 3)
vector_aro(g) = Cells(i, k + 4)
vector_picking(g) = Cells(i, j)
vector_modelo(g) = Cells(i, k + 2)
g = g + 1
bulean = 1
End If
i = i + 1
Loop
If bulean = 1 Then
Sheets("CONSECUTIVO").Select
Do Until Cells(m, j + 13) = ""
m = m + 1
Loop
If Cells(m, 1) < 10 Then
Var = cv & "-" & "000" & Cells(m, 1)
Else
Var = cv & "-" & "00" & Cells(m, 1)
End If
Cells(m, j - 13) = Var
Sheets("FORMATO").Select
Sheets("FORMATO").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = cv
Do Until vector_codigo(b) = ""
Cells(y, t) = vector_codigo(b)
Cells(y, t + 1) = vector_fab(b)
Cells(y, t + 3) = vector_color(b)
Cells(y, t + 4) = vector_aro(b)
Cells(y, t + 5) = vector_picking(b)
Cells(y, t + 2) = vector_modelo(b)
b = b + 1
y = y + 1
Loop
Range("e5") = Var
Range("b6") = cv
Range("b5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Do Until Cells(r, 1) = ""
suma = Cells(r, 6) + suma
r = r + 1
Loop
Cells(r, 6) = suma
Cells(r, 1) = "TOTAL"
Range(Cells(12, 1), Cells(r, 6)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Cells(r + 2, 1) = "RECIBE"
Cells(r + 4, 1) = "_____________________"
Cells(r + 4, 2) = "_______________"
Cells(r + 5, 1) = "Fecha:"
Cells(r + 5, 2) = "_______________"
Sheets("Base").Select
b = 1
y = 12
r = 12
g = 1
suma = 0
Do Until b = 2000
vector_picking(b) = ""
vector_aro(b) = ""
vector_color(b) = ""
vector_codigo(b) = ""
vector_fab(b) = ""
vector_modelo(b) = ""
b = b + 1
Loop
b = 1
End If
j = j + 1
i = 7
bulean = 0
Loop
End Sub