Insert row, modify original & inserted rows

[1cor1_27]

In Excel, I need to check for percents >0 and <100 in multiple columns, insert a new row with copied data from that row, and modify both rows. If this occurs in--for example--Row 27, I need to copy Row 27 and insert the copied row before Row 28, while changing the percents in both rows and also an amount from a different column. The percent data is in columns X through AG, and the amount data is in column AH.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
<o>----</o>
Example:<o></o>
Row 27: Column X (40%) ... Column AD (60%) ... Column AH ($10,000)<o></o>
<o></o>
This needs to become as follows:<o></o>
Row 27: Column X (100%) ... Column AD (0%) ... Column AH ($4,000*)<o></o>
Row 28**: Column X (0%) ... Column AD (100%) ... Column AH ($6,000*)<o></o>

*Calcuated by multiplying the original % by the original amount (e.g. 40% * $10k = $4k)
**Inserted by the macro<o></o>
<o></o>
I want everything in Row 28 to be identical to that in Row 27 (values, formulas, etc)--EXCEPT for the modified columns (percents/amounts).
----<o></o>
<o></o>
Hopefully this makes sense. Can anyone help?

 

[shg]

Sub x()
    Dim rPct        As Range    ' percentages totaling 0 (ignored) or 1 in each row
    Dim rAmt        As Range    ' revenue amount
    Dim iRow        As Long     ' row index
    Dim iCol        As Long     ' column index
    Dim nCol        As Long     ' number of columns
 
    Set rAmt = ActiveSheet.Range("N2", ActiveSheet.Cells(Rows.Count, "N").End(xlUp))
    Set rPct = Intersect(rAmt.EntireRow, Columns("D:M"))
    nCol = rPct.Columns.Count
 
    For iRow = rPct.Rows.Count To 1 Step -1
        Select Case Round(WorksheetFunction.Sum(rPct.Rows(iRow)), 6)
            Case 0#
                ' do nothing
 
            Case 1#
                With rPct.Rows(iRow).EntireRow
                    .Copy
                    .Offset(1).Resize(nCol).Insert
                    rPct.Rows(iRow).Offset(1).Resize(nCol).Value2 = 0#
                End With
 
                For iCol = nCol To 1 Step -1
                    If rPct(iRow, iCol).Value2 = 0# Then
                        rPct.Rows(iRow).Offset(iCol).EntireRow.Delete
                    Else
                        rPct(iRow, iCol).Offset(iCol).Value2 = 1#
                        rAmt(iRow).Offset(iCol).Value = rPct(iRow, iCol).Value2 * rAmt(iRow).Value2
                    End If
                Next iCol
 
                rPct.Rows(iRow).Interior.Color = vbGreen
                'rPct.Rows(iRow).EntireRow.Delete
 
            Case Else
                If Round(WorksheetFunction.Sum(rPct.Rows(iRow)), 6) <> 1# Then
                    With rPct.Rows(iRow)
                        .Interior.Color = vbRed
                        .Select
                    End With
                    MsgBox "Total <> 100%"
                    Exit Sub
                End If
        End Select
    Next iRow
End Sub

 

[1cor1_27]

Thanks, shg--I really appreciate all the help! If I knew how, I would mark this question "answered" (though I'm not sure if this forum uses that or not).

Just in case someone else has a similar problem and wants to see the solution, here's the code I finally ended up using:

--------
Sub x()
Dim rPct As Range
Dim rAmt As Range
Dim iRow As Long
Dim iCol As Long
Dim nCol As Long

Set rAmt = ActiveSheet.Range("X2:X456", ActiveSheet.Cells(Rows.Count, "AG").End(xlUp))
Set rPct = Intersect(rAmt.EntireRow, Columns("X:AG"))
Set rAmt = Intersect(rPct.EntireRow, Columns("AH"))
nCol = rPct.Columns.Count

For iRow = rPct.Rows.Count To 1 Step -1
Select Case Round(WorksheetFunction.Sum(rPct.Rows(iRow)), 0)
Case 0#

Case 1#
With rPct.Rows(iRow).EntireRow
.Copy
.Offset(1).Resize(nCol).Insert
rPct.Rows(iRow).Offset(1).Resize(nCol).Value2 = 0#
End With

For iCol = nCol To 1 Step -1
If rPct(iRow, iCol).Value2 = 0# Then
rPct.Rows(iRow).Offset(iCol).EntireRow.Delete
Else
rPct(iRow, iCol).Offset(iCol).Value2 = 1#
rAmt(iRow).Offset(iCol).Value = rPct(iRow, iCol).Value2 * rAmt(iRow).Value2
End If
Next iCol

rPct.Rows(iRow).EntireRow.Delete

Case Else
If Round(WorksheetFunction.Sum(rPct.Rows(iRow)), 0) <> 1# Then
With rPct.Rows(iRow)
.Interior.Color = vbRed
.Select
End With
MsgBox "Total <> 100%"
Exit Sub
End If
End Select
Next iRow
End Sub
--------

Really, the only thing that needed to be changed was removing the "Green" condition, inserting the "Set rAmt = Intersect..." line, and then defining the range "Set rAmt = ActiveSheet.Range("X2:X456", [...])" (the 456 is based on the number of rows in the spreadsheet).

If you have a similar situation, beware that it might take a long time for the macro to run through the entire spreadsheet (especially if you have a few dozen columns of information). I copied the relevant rows into a new spreadsheet, ran the macro on them, and then pasted the new rows back into the spreadsheet over the old rows. Worked like a charm, and was much faster than doing it manually!

 

[shg]

You're welcome.

beware that it might take a long time for the macro to run through the entire spreadsheet

See Help for Application.ScreenUpdating