Good Morning/Afternoon/Evening, all. Unfortunately for me, I'm back with another brows furrowed, scratching my head question. It seems that the code that John H Davis so kindly helped me with is displaying a hiccup that I didn't notice until after the spreadsheet had been in use for a few days. In the final steps of John's solution for me, the row that was calculated on Sheet2 for each unique rep name is copied and placed back on Sheet1 into the blank row that was created beneath that unique rep's name. What one of the Supervisors here discovered is that the very last unique rep's calculated row isn't copied back to Sheet1; everyone's is except for that very last rep. The following is the code block where the calculation occurs on Sheet2 for each unique rep, labels are added and the row is copied back to Sheet1:
Dim ws As Worksheet
Dim rcell As Range
Dim scell As Range
Dim x As String
'Find the first blank row beneath each unique Rep name and sum the values for that unique Rep in column C
For Each numrange In Columns("C").SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = numrange.Address(False, False)
numrange.Offset(numrange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")"
c = numrange.Count
Next numrange
'Find the first blank row beneath each unique Rep name and sum the values for that unique Rep in column F
For Each numrange In Columns("F").SpecialCells(xlFormulas, xlNumbers).Areas
SumAddr = numrange.Address(False, False)
numrange.Offset(numrange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")"
c = numrange.Count
Next numrange
'Find the first blank row beneath each unique Rep name and sum the values for that unique Rep in column G
For Each numrange In Columns("G").SpecialCells(xlFormulas, xlNumbers).Areas
SumAddr = numrange.Address(False, False)
numrange.Offset(numrange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")"
c = numrange.Count
Next numrange
NoData:
'Calculate Blended Averages and add labels
Set ws = ActiveSheet
For Each rcell In Range("A2:A500")
If rcell.Offset(, 1).Value = "" And rcell.Offset(, 2).Value <> "" Then
'Move the cursor to column D and calculate Blended AHT - the If statement accounts for division by zero
'rcell.Offset(, 3).Value = rcell.Offset(, 5).Value / rcell.Offset(, 2).Value 'This is the original code
If rcell.Offset(, 2).Value = 0 Then
rcell.Offset(, 3).Value = 0
Else
rcell.Offset(, 3).Value = rcell.Offset(, 5).Value / rcell.Offset(, 2).Value
End If
'Move the cursor to column E and calculate Blended ACW - the If statement accounts for division by zero
'rcell.Offset(, 4).Value = rcell.Offset(, 6).Value / rcell.Offset(, 2).Value 'This is the original code
If rcell.Offset(, 2).Value = 0 Then
rcell.Offset(, 4).Value = 0
Else
rcell.Offset(, 4).Value = rcell.Offset(, 6).Value / rcell.Offset(, 2).Value
End If
'Place the unique Rep Name into column A
rcell.Value = rcell.Offset(-1).Value
'Place the split label into column B
rcell.Offset(, 1).Value = "Blended Splits"
x = rcell.Offset(-1).Value
End If
'Copies the resulting line from Sheet2 and places it in on the blank line beneath the same name in Sheet1
For Each scell In Sheets("Sheet1").Range("A2:A" & Sheets("Sheet1").Range("A" & Rows.Count).End(3)(1).Row)
If scell.Value = "" And scell.Offset(-1).Value = x Then
Range(scell, scell.Offset(, 4)).Value = Range(rcell, rcell.Offset(, 4)).Value
End If
Next scell
ws.Activate
Next rcell
As in the past on this thread, I hope I've sufficiently explained the situation. If not, please share any questions you might have. If anyone would care to help, I'd sincerely appreciate it. Make it a great day!
Bookmarks