Trying to write a Loop to perform calculations within blank rows between populated rows

**ObliviousAmI** · 01-02-2014, 09:54 PM

Good morning/afternoon/evening all. I hope someone is up for (what I think is) a challenge as I've reached the end of my meager expertise!

I'm using Excel 2010 with the workbook in question saved as an Excel 97-2003 Workbook in Compatibilty Mode.

I've been able to piece together a macro that searches Sheet1 (please see the attached workbook) for specific elements in column B then transfers that individual row to Sheet2. I've then sorted both Sheets 1 & 2 by column A, added labels and placed Sheet2's cursor in cell C5 (as per the attached workbook). Looking at Sheet 2 row 5 in the example, I now need to write a Loop statement that will sum columns C, F & G for each unique Rep Name in column A placing those resulting values in C5, F5 & G5, calculate D5 as (F5 * C5) and calculate E5 as (G5 * C5). I then need to copy the name "Emp1" into cell A5, add a label ("Combined Average" or something TBD) to cell B5, move down to the next blank row beneath the next unique Rep Name & repeat the process. Once all calculations are complete, I need to copy each resulting row back into Sheet1 beneath the corresponding unique Rep Name.

The information in and length of Sheet1 will vary from day to day, so the elements being transferred to Sheet2 will never be identical (the Supervisors will be pasting new information into Sheet1 cell A1 every day). Due to that I'm not able to complete Sheet2 with static cell references. The number of blank rows between unique Rep Names as you see in the example can be altered if necessary; I thought having a blank row above & beneath each unique Rep Name might make it easier to perform the calculations.

I don't believe the macro as it exists needs to be added here as it performs flawlessly (so far!). My sincere hope is that someone can assist with the loop statement as I've outlined. If you would like to see the code as it exists now, I'll be happy to add it at your request.

I look forward to any assistance! Thank you for reading my post.

**rcm** · 01-02-2014, 10:39 PM

let us take a look at the macro, your needs can be in bedded in it

**jolivanes** · 01-03-2014, 02:04 AM

See if this works for the first part of your rquirement

Sub Add_Areas()
    Dim Area As Range, rng As Range
    For Each Area In Range("A3", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
        Set rng = Area.Cells(Area.Cells.Count).Offset(1)

        With rng
            .Value = .Offset(-1).Value
            .Offset(, 1).Formula = "Combined Averages"
            .Offset(, 2).Value = WorksheetFunction.Sum(Area.Offset(, 2))
            .Offset(, 5).Value = WorksheetFunction.Sum(Area.Offset(, 5))
            .Offset(, 6).Value = WorksheetFunction.Sum(Area.Offset(, 6))
            .Offset(, 3).Value = .Offset(, 2).Value * .Offset(, 5).Value
            .Offset(, 4).Value = .Offset(, 2).Value * .Offset(, 6).Value
        End With

    Next Area
End Sub

**JOHN H. DAVIS** · 01-03-2014, 11:59 AM

Another:

Sub ObliviousAmI()
Dim rcell As Range
Application.ScreenUpdating = False
    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
     
    For Each numrange In Columns("F").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

    For Each numrange In Columns("G").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
NoData:

For Each rcell In Range("A2:A1000")
    If rcell.Offset(, 1).Value = "" And rcell.Offset(, 2).Value <> "" Then
    rcell.Offset(, 3).Value = rcell.Offset(, 2).Value * rcell.Offset(, 5).Value
    rcell.Offset(, 4).Value = rcell.Offset(, 2).Value * rcell.Offset(, 6).Value
    rcell.Value = rcell.Offset(-1).Value & " Combined Average"
    End If
Next rcell
Application.ScreenUpdating = True
End Sub

I was working with Sheet2 in your example?

**ObliviousAmI** · 01-03-2014, 02:06 PM

Good morning, John H Davis. I tried your code today, and the first loop (for column C) worked like a gem, then I found I needed to modify your second and third loops as the cells in columns F & G contain formulas instead of numeric values. Once I had done that, those loops worked beautifully, too. I found I also had to slightly modify your code in the final line of the last loop ("rcell.Value = rcell.Offset(-1).Value & " Combined Average") as my request hadn't been altogether clear. I needed to have the unique Rep Name from column A brought down to the first blank row (which your code does), but then I needed to have the next label placed in column B rather than concatenating the name & "Combined Average" both in column A, so I added "rcell.Offset(, 1).Value = "Combined Average"" which did exactly what I needed.

My final question is this: How do I move columns A:E of each resultant row back to Sheet1 into the blank space that I've already placed beneath each unique Rep Name? Some of the cells (column C) contain formulas rather than numeric values, so I need to take that into consideration when the rows are transferred.

Thanks again for the help, John. It was outstanding! I'm studying your code today to learn more from it so I don't have to ask so many questions! 'Preciate it. If you or anyone can help with this last bit, I'll be grateful.

**JOHN H. DAVIS** · 01-03-2014, 02:40 PM

Not sure about the changes you made for Columns F & G so you'll have to reedit this for those changes.

Sub ObliviousAmI()
Dim ws As Worksheet
Dim rcell As Range
Dim scell As Range
Dim x As String
Application.ScreenUpdating = False
Set ws = ActiveSheet
    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
     
    For Each numrange In Columns("F").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

    For Each numrange In Columns("G").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
NoData:

For Each rcell In Range("A2:A32")
    If rcell.Offset(, 1).Value = "" And rcell.Offset(, 2).Value <> "" Then
    rcell.Offset(, 3).Value = rcell.Offset(, 2).Value * rcell.Offset(, 5).Value
    rcell.Offset(, 4).Value = rcell.Offset(, 2).Value * rcell.Offset(, 6).Value
    rcell.Value = rcell.Offset(-1).Value
    rcell.Offset(, 1).Value = "Combined Average"
    x = rcell.Offset(-1).Value
    End If
    For Each scell In Sheets("Sheet1").Range("A2:A50")
        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

Application.ScreenUpdating = True
End Sub

**ObliviousAmI** · 01-03-2014, 12:34 PM

Thanks for looking at this, rcm. Here's the macro as it exists. I've heavily noted it for myself as I don't understand vbs code for Excel as well as I should:

Sub MoveSplits()
'
' MoveSplits Macro
' This macro will delete Row 1 and Columns F:AE, search for each instance of the five desired splits,
' move each of those rows to Sheet2, sort the result by the employee's name, calculate AHT and ACW on the existing splits,
' adds 2 blank rows, add labels, freeze the top row and format all columns
'
    Application.ScreenUpdating = False
    
    'Delete Row 1
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp

    'Delete Columns F:AE
    Columns("F:AE").Select
    Selection.Delete Shift:=xlToLeft
    
    'Select Columns A:E then alphabetizes them sorted by Column A (Rep Name column)
    Columns("A:E").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A500") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:E500")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Format Columns D:E as a number with no decimal places
    Columns("D:E").Select
    Selection.NumberFormat = "0"
    
    'Resize Columns A:G to fit the largest cell
    Columns("A:G").Select
    Columns("A:G").EntireColumn.AutoFit
    
    'Find the last instance of each unique name in Column A and add a blank row beneath it
    Dim lRow As Long
    For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 2 Step -1
    If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then Rows(lRow).EntireRow.Insert
    Next lRow
    
    'Insert a row at the top for labels, add "AHT" to Cell F1 & "ACW" to Cell G1
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Rep Name"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Split"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "#Calls"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "AHT"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "ACW"
    
    'Select Cells B1:G1 and center-aligns them as they're labels
    Range("B1:G1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    'Resize Columns A:E to fit the largest cell
    Columns("A:E").Select
    Columns("A:E").EntireColumn.AutoFit
    
    'Freeze the top row
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

    'Select Cell A1
    Range("A1").Select

    'Search for the string "CS MAIN            1", copies the entire row and pastes it into the first available row in Sheet2
    Dim xRow&, NextRow&, LastRow&
    NextRow = 1
    LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For xRow = 1 To LastRow
    If WorksheetFunction.CountIf(Rows(xRow), "CS MAIN            1") > 0 Then
    Rows(xRow).Copy Sheets("Sheet2").Rows(NextRow)
    NextRow = NextRow + 1
    End If
    Next xRow
    
    'Search for the string "CS GCS            12", copies the entire row and pastes it into the first available row in Sheet2
    NextRow = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For xRow = 1 To LastRow
    If WorksheetFunction.CountIf(Rows(xRow), "CS GCS            12") > 0 Then
    Rows(xRow).Copy Sheets("Sheet2").Rows(NextRow)
    NextRow = NextRow + 1
    End If
    Next xRow
    
    'Search for the string "CS REFILLS        33", copies the entire row and pastes it into the first available row in Sheet2
    NextRow = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For xRow = 1 To LastRow
    If WorksheetFunction.CountIf(Rows(xRow), "CS REFILLS        33") > 0 Then
    Rows(xRow).Copy Sheets("Sheet2").Rows(NextRow)
    NextRow = NextRow + 1
    End If
    Next xRow
    
    'Search for the string "Retail            74", copies the entire row and pastes it into the first available row in Sheet2
    NextRow = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For xRow = 1 To LastRow
    If WorksheetFunction.CountIf(Rows(xRow), "Retail            74") > 0 Then
    Rows(xRow).Copy Sheets("Sheet2").Rows(NextRow)
    NextRow = NextRow + 1
    End If
    Next xRow
    
    'Search for the string "Diabetic Meter    79", copies the entire row and pastes it into the first available row in Sheet2
    NextRow = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For xRow = 1 To LastRow
    If WorksheetFunction.CountIf(Rows(xRow), "Diabetic Meter    79") > 0 Then
    Rows(xRow).Copy Sheets("Sheet2").Rows(NextRow)
    NextRow = NextRow + 1
    End If
    Next xRow
    
    'Rename sheet
'    If Environ("USERNAME") = "SAPOLZ" Then
'        ActiveSheet.Name = "Team Paradise as of " & Format(Now() - 1, "mm-dd-yyyy")
'    ElseIf Environ("USERNAME") = "C34317" Then
'        ActiveSheet.Name = "Team Ganje as of " & Format(Now() - 1, "mm-dd-yyyy")
'    ElseIf Environ("USERNAME") = "TKSEVE" Then
'        ActiveSheet.Name = "Team Severson as of " & Format(Now() - 1, "mm-dd-yyyy")
'    ElseIf Environ("USERNAME") = "C40757" Then
'        ActiveSheet.Name = "Team Gochal as of " & Format(Now() - 1, "mm-dd-yyyy")
'    ElseIf Environ("USERNAME") = "DLDARD" Then
'        ActiveSheet.Name = "Team Dardis as of " & Format(Now() - 1, "mm-dd-yyyy")
'    ElseIf Environ("USERNAME") = "LJHAAG" Then
'        ActiveSheet.Name = "Team Gartamaker as of " & Format(Now() - 1, "mm-dd-yyyy")
'    ElseIf Environ("USERNAME") = "C35119" Then
'        ActiveSheet.Name = "Team Kathman as of " & Format(Now() - 1, "mm-dd-yyyy")
'    Else
'    End If
        
    'Select Sheet2 to make it the active sheet
    Sheets("Sheet2").Select

    'Select Columns A:E then alphabetize them sorted by Column A (Rep Name column)
    Columns("A:E").Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A1:A500") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A1:E500")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Enter the following formula in Cell F1 and extend it to Cell F500: "If(A1="","",D1*C1)"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]="""","""",RC[-2]*RC[-3])"
    Selection.AutoFill Destination:=Range("F1:F500"), Type:=xlFillDefault
    Range("F1:F500").Select

    'Enter the following formula in Cell G1 and extend it to Cell F500: "If(A1="","",E1*C1)"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-6]="""","""",RC[-2]*RC[-4])"
    Selection.AutoFill Destination:=Range("G1:G500"), Type:=xlFillDefault
    Range("G1:G500").Select
        
    'Format Columns D:G as a number with no decimal places
    Columns("D:G").Select
    Selection.NumberFormat = "0"

    'Find the last instance of each unique name in Column A and adds 2 blank rows beneath it
    Const blanks = 2
    Dim lastValue As String, i As Long, r As Long
    Do
        r = r + 1
        If r > 1 And lastValue <> Cells(r, 1).Value Then
            If Cells(r, 1).Value = "" Then Exit Do
            For i = 1 To blanks
                Rows(r).Insert Shift:=xlDown
            Next
            r = r + blanks
        End If
        lastValue = Cells(r, 1).Value
    Loop
    
    'Select Columns C:G and right-align them as they're numbers
    Columns("C:G").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    'Insert two rows at the top for labels and an additional blank row, add labels to each Column
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Rep Name"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Split"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "#Calls"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "AHT"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "ACW"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Combined AHT"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Combined ACW"
    
    'Select Cells B1:G1 and center-align them as they're labels
    Range("B1:G1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    'Resize Columns A:G to fit the largest cell
    Columns("A:G").Select
    Columns("A:G").EntireColumn.AutoFit
    
    'Freeze the top row
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
            
    'Find and go to Column C in the first blank row
    Application.Goto Range("A3").End(xlDown).Offset(1, 2)
    
    'Rename Sheet
    'ActiveSheet.Name = "Combined Stats Calculations"
    
    Application.ScreenUpdating = True

End Sub

**ObliviousAmI** · 01-06-2014, 04:44 PM

That works absolutely PERFECTLY! Once again, my thanks to you, John! You've proven yourself invaluable again! I was confident that's what needed to be done, but I just didn't know how to write the code for that line. My sincere gratitude to you for all your efforts!

**JOHN H. DAVIS** · 01-06-2014, 04:45 PM

Again welcome. And Glad to hear it works for you.

**ObliviousAmI** · 01-15-2014, 01:35 PM

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!

**JOHN H. DAVIS** · 01-15-2014, 02:27 PM

This was set for a range to 500. I'm not certain that I understand your problem but try making this change.

    'Calculate Blended Averages and add labels
    Set ws = ActiveSheet
    For Each rcell In Range("A2:A" & Range("A" & rows.count).End(3)(2).row)
        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

**ObliviousAmI** · 01-15-2014, 06:35 PM

John, again, thanks for your rapid reply. Unfortunately, changing that line of code didn't make a difference. So I thought outside the box and decided that, rather than changing the For loop, since the affected row is always the final row on Sheet2, I would copy that row and paste it to the first empty row in Sheet1. Here's the code snippet that I used (it might be somewhat clumsy as I assembled it from various sources I found while researching this-you would likely write something far more elegant):

'Copy the final row on Sheet2 to Sheet1
    Sheets("Sheet2").Select
    LastRowColA = Range("A65536").End(xlUp).Row
    Range("A" & LastRowColA & ":E" & LastRowColA).Copy
    Sheets("Sheet1").Select
    LCopyToRow = Range("A" & Rows.Count).End(xlUp).Row + 1
    Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
    ActiveSheet.Paste

I just added this after the end of the For loop you wrote for me (above) and found my problem resolved! Thanks for your efforts; they're much appreciated.

Trying to write a Loop to perform calculations within blank rows between populated rows

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Trying to write a Loop to perform calculations within blank rows between populated rows

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Re: Trying to write a Loop to perform calculations within blank rows between populated row

Thread Information

Users Browsing this Thread

Similar Threads

How to perform 'insert rows' instead of 'copy rows' using .copyrecordset (excel vba)

[SOLVED] Perform calculations for multiple rows based on specific column text

loop through rows for match insert blank rows with title

Deleting blank rows using loop and SpecialCells

Deleting blank rows using loop and SpecialCells

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions