Macros with SUMIFS that changes dependent on month

[WadeLair]

CAP - Tool for posting.xlsmI need help with both formulas/function AND a macro.
I have attached a workbook. I am trying to use a macro to fill in the red boxes (I have just made the cells red to make this easier to understand, the macro doesn’t need to do this). The report attached contains several months of data. In this case, the report starts with January. I need formulae that add up the weekday and weekend data. The weekday total –current like (for example, row 146) should add up the figures in the same column that are weekdays (as indicated in column “A”) that are on the current line for the various dates. The next row should add up the “Last Yr,” line and the weekend totals section should do the same for weekends.

The reason why I think I need a macro to plug in these formulas is the report could change every time it is ran, so I think a macro that searched for the right area of the spreadsheet to add would be brilliant. I’m open to other ideas if there are any. I really appreciate any help you can give.
Thanks!

[xladept]

Hi Wadelair,

Here's a macro for the 24 fields in the red boxes - let me know of any issues:

Sub Wadelair(): Dim AccumD(25), AccumE(25) As Single, AccumT(25) As Single
Dim r As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long
r = Cells.Find("This").row: Set D = Range("D1:D" & r): h = 1
j = D.Find("Short").row + 1: k = D.Find("Total").row - 1
ProcessBlock:

If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 11

h = InStr(1, Cells(i, m), "$")
If h Then
S = Cells(i, m)
Cells(i, m) = Mid(S, 1, h - 1) & _
Mid(S, h + 1, Len(S) - 1): End If

If Left(Cells(i, m), 1) = "+" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)


AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 25 Then n = 1
If n = 7 Or n = 13 Or n = 19 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 11

h = InStr(1, Cells(i, m), "$")
If h Then
S = Cells(i, m)
Cells(i, m) = Mid(S, 1, h - 1) & _
Mid(S, h + 1, Len(S) - 1): End If

If Left(Cells(i, m), 1) = "+" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)

AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 25 Then n = 1
If n = 7 Or n = 13 Or n = 19 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 11
Cells(i, m) = AccumD(n): n = n + 1
Next m
If n = 19 Then n = 1
If n = 7 Or n = 13 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1
PostWEs:
For m = 6 To 11
Cells(i, m) = AccumE(n): n = n + 1
Next m
If n = 19 Then n = 1
If n = 7 Or n = 13 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
       
j = D.Find("Short", Range("D" & i)).row + 1
k = D.Find("Total", Range("D" & j)).row - 1
GoTo ProcessBlock

End Sub

[WadeLair]

Thank you very much for your help. This works brilliantly, but can you help me understand what is going on a little more?

Maybe some comments in the block would help me...Thanks again.

[xladept]

Hi Wadelair - glad you like it - here is a commented version:

Sub Wadelair(): Dim AccumD(25), AccumE(25) As Single, AccumT(25) As Single
Dim r As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long
r = Cells.Find("This").row: Set D = Range("D1:D" & r): h = 1
'Use the notice at the end to define the scope of the data
j = D.Find("Short").row + 1: k = D.Find("Total").row - 1
'Find the start j  and the end k of the first block
ProcessBlock:
'The finder repeats from the beginning
If i > j Then Exit Sub       'so this signals that all blocks have been processed
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then 'We use AccumD for the weekdays
Weekdays:           'the array is set to 25 since the first element is AccumD(0)
For m = 6 To 11     'Columns 6 to 11 hold the data

h = InStr(1, Cells(i, m), "$")
If h Then  'the cells formatted as text have a visible (to Excel) $
S = Cells(i, m) 'so if xl sees a $ we strip it out
Cells(i, m) = Mid(S, 1, h - 1) & _
Mid(S, h + 1, Len(S) - 1): End If

If Left(Cells(i, m), 1) = "+" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1) 'get rid of any +

'AccumT for Totals for possible use in a later version
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 25 Then n = 1
If n = 7 Or n = 13 Or n = 19 Then
i = i + 1: GoTo Weekdays: End If: End If
'Comments for this weekend routine are analogous to the Weekday routine
If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 11

h = InStr(1, Cells(i, m), "$")
If h Then
S = Cells(i, m)
Cells(i, m) = Mid(S, 1, h - 1) & _
Mid(S, h + 1, Len(S) - 1): End If

If Left(Cells(i, m), 1) = "+" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)

AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 25 Then n = 1                'Reset the index for the next 24 values
If n = 7 Or n = 13 Or n = 19 Then   'Reiterate for the next 6 values
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:                            'The SubTotals come right after the data
For m = 6 To 11
Cells(i, m) = AccumD(n): n = n + 1
Next m
If n = 19 Then n = 1                'Only 18 Subtotals are displayed
If n = 7 Or n = 13 Then             'Reiterate for the next 6 values
i = i + 1: GoTo PostWDs: End If: i = i + 1
PostWEs:                            'The SubTotals follow the other subtotals
For m = 6 To 11
Cells(i, m) = AccumE(n): n = n + 1
Next m
If n = 19 Then n = 1
If n = 7 Or n = 13 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE      'Clear the weekday and weekend accumulators
       
j = D.Find("Short", Range("D" & i)).row + 1     'Find start of next block
k = D.Find("Total", Range("D" & j)).row - 1     'Find end of next block
GoTo ProcessBlock

'In this program the unrecognized.unusable text was changed on the sheet to usable
'We could have left it unchanged on the sheet and still have processed it???

End Sub

[WadeLair]

CAP - Tool for posting.xlsmSorry to keep picking at this, but I have a few more issues. I think this makes it more complicated. I have uploaded a file again. I want to use the macro to fill in formulas our to column "Y".

Then, I need some way to stop the process and use formulas to fill in the cells in green. Any ideas?

[xladept]

Hi Wadelair,

I upped all the numbers but had to code a bypass errors - see if it's what you wanted:

Sub Wadelair2(): Dim AccumD(81), AccumE(81) As Single, AccumT(81) As Single
Dim R As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long
R = Cells.Find("This").Row: Set D = Range("D1:D" & R): h = 1
j = D.Find("Short").Row + 1: k = D.Find("Total").Row - 1
ProcessBlock:
If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 25
On Error Resume Next
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 25
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 25
Cells(i, m) = AccumD(n): n = n + 1
Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1
PostWEs:
For m = 6 To 25
Cells(i, m) = AccumE(n): n = n + 1
Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
        
j = D.Find("Short", Range("D" & i)).Row + 1
k = D.Find("Total", Range("D" & j)).Row - 1
GoTo ProcessBlock

End Sub

[WadeLair]

This fills in the cells, but itt does include the ones I colored green.

Can you think of any way that I could go back and enter formulae in those green cells?

[xladept]

Hi Wadelair,

This will post only in the red cells (They have to be red). What Formulae are you considering?

Sub Wadelair2(): Dim AccumD(81), AccumE(81) As Single, AccumT(81) As Single
Dim R As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long
R = Cells.Find("This").Row: Set D = Range("D1:D" & R): h = 1
j = D.Find("Short").Row + 1: k = D.Find("Total").Row - 1
ProcessBlock:
If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 25
On Error Resume Next
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 25
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 25
If Cells(i, m).Interior.ColorIndex = 3 Then _
Cells(i, m) = AccumD(n): n = n + 1
Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1
PostWEs:
For m = 6 To 25
If Cells(i, m).Interior.ColorIndex = 3 Then _
Cells(i, m) = AccumE(n): n = n + 1
Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
        
j = D.Find("Short", Range("D" & i)).Row + 1
k = D.Find("Total", Range("D" & j)).Row - 1
GoTo ProcessBlock

End Sub

[WadeLair]

For me, this doesn't populate correctly. This gives a maximum of two rows when the color red is in the cell. Any ideas?

in column H, the formula is (same row) Column J/F,
in column I, column K/G.
In column L, (F/(F+G)).
In column M, J/HotelSupply
In column N, (K/(SetCapacity-HotelSupply))
In column O, M/N



in column R, the formula is (same row) Column T/P,
in column S, column U/Q.
In column V, (P/(P+Q)).
In column W, T/HotelSupply
In column X, (U/(SetCapacity-HotelSupply))
In column Y, W/X

[xladept]

Sub Wadelair2(): Dim AccumD(81), AccumE(81) As Single, AccumT(81) As Single
Dim R As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long, U, V
R = Cells.Find("This").row: Set D = Range("D1:D" & R): h = 1
j = D.Find("Short").row + 1: k = D.Find("Total").row - 1
ProcessBlock:
If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 25
On Error Resume Next
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 25
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 25
If Cells(i, m).Interior.ColorIndex = 3 Then _
Cells(i, m) = AccumD(n)
n = n + 1: Next m

Range("H" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("I" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("L" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("M" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("N" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("O" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"
Range("R" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("S" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("V" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("W" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("X" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("Y" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"

If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1

PostWEs:
For m = 6 To 25
If Cells(i, m).Interior.ColorIndex = 3 Then _
Cells(i, m) = AccumE(n)
n = n + 1: Next m

Range("H" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("I" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("L" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("M" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("N" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("O" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"
Range("R" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("S" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("V" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("W" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("X" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("Y" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"

If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
        
j = D.Find("Short", Range("D" & i)).row + 1
k = D.Find("Total", Range("D" & j)).row - 1
GoTo ProcessBlock

End Sub

I get a reference error on Hotel Supply!

[xladept]

The n index wasn't being incremented, for some reason (or no reason at all) the routine was skipping over that code:

Here's the fix:

Sub Wadelair2(): Dim AccumD(81), AccumE(81) As Single, AccumT(81) As Single
Dim R As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long
R = Cells.Find("This").Row: Set D = Range("D1:D" & R): h = 1
j = D.Find("Short").Row + 1: k = D.Find("Total").Row - 1
ProcessBlock:
If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 25
On Error Resume Next
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 25
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 25
If Cells(i, m).Interior.ColorIndex = 3 Then _
Cells(i, m) = AccumD(n)
n = n + 1: Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1
PostWEs:
For m = 6 To 25
If Cells(i, m).Interior.ColorIndex = 3 Then _
Cells(i, m) = AccumE(n)
n = n + 1: Next m
If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
        
j = D.Find("Short", Range("D" & i)).Row + 1
k = D.Find("Total", Range("D" & j)).Row - 1
GoTo ProcessBlock

End Sub

Are SetCapacity-HotelSupply calculated numbers or are they on the sheet under another guise??

[WadeLair]

They are named ranges, their original location is on the "Competitive Set," sheet in the workbook.

[xladept]

You know - since we're overwriting the "green" fields there is no reason to restrict the first writing to only "red" fields:

Sub Wadelair2(): Dim AccumD(81), AccumE(81) As Single, AccumT(81) As Single
Dim r As Long, D As Range, S As String, m As Integer, n As Integer: n = 1
Dim h As Long, i As Long, j As Long, k As Long, U, V
r = Cells.Find("This").row: Set D = Range("D1:D" & r): h = 1
j = D.Find("Short").row + 1: k = D.Find("Total").row - 1
ProcessBlock:
If i > j Then Exit Sub
For i = j To k
If Cells(i, 1) = "WEEKDAY" Then
Weekdays:
For m = 6 To 25
On Error Resume Next
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumD(n) = AccumD(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekdays: End If: End If

If Cells(i, 1) = "WEEKEND" Then
Weekends:
For m = 6 To 25
If Left(Cells(i, m), 1) = "$" Then _
S = Cells(i, m): Cells(i, m) = Right(S, Len(S) - 1)
AccumT(n) = AccumT(n) + Val(Cells(i, m))
AccumE(n) = AccumE(n) + Val(Cells(i, m)): n = n + 1
Next m
If n = 81 Then n = 1
If n = 21 Or n = 41 Or n = 61 Then
i = i + 1: GoTo Weekends: End If
End If
Next i: n = 1

PostWDs:
For m = 6 To 25
Cells(i, m) = AccumD(n)
n = n + 1: Next m

Range("H" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("I" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("L" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("M" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("N" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("O" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"
Range("R" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("S" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("V" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("W" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("X" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("Y" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"

If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWDs: End If: i = i + 1

PostWEs:
For m = 6 To 25
Cells(i, m) = AccumE(n)
n = n + 1: Next m

Range("H" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("I" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("L" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("M" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("N" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("O" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"
Range("R" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("S" & i).FormulaR1C1 = "=RC[2]/RC[-2]"
Range("V" & i).FormulaR1C1 = "=RC[-6]/(RC[-6]+RC[-5])"
Range("W" & i).FormulaR1C1 = "=RC[-3]/HotelSupply"
Range("X" & i).FormulaR1C1 = "=RC[-3]/SetCapacity-HotelSupply"
Range("Y" & i).FormulaR1C1 = "=RC[-2]/RC[-1]"

If n = 61 Then n = 1
If n = 21 Or n = 41 Then
i = i + 1: GoTo PostWEs: End If

        Erase AccumD: Erase AccumE
        
j = D.Find("Short", Range("D" & i)).row + 1
k = D.Find("Total", Range("D" & j)).row - 1
GoTo ProcessBlock

End Sub