Add lines and duplicate data a set number of times

问题:

I am trying to write a VBA Excel Macro to look through hundreds of thousands of lines of data to make sure that each unique entry in column A has a number of entries equal to column C.

For example:

Source Account Id 84512 occurs 6 times but there needs to be 12 occurrences (as indicated by column C). This means I need to add 6 lines, before (or after) the existing 6 lines.

Next we see Source Account Id 64857 occurs once but needs to occur 5 times. I would add 4 lines above and have the same Source Account Id code and the same Account Name. The rest of the cells can be "0".

Here is an example of the finished product:

Here is what I have so far:

Sub InsertRowAtChangeInValue()
   Dim lRow As Long
   Dim nMonths As Long
   
   For lRow = Cells(Cells.Rows.count, "A").End(xlUp).Row To 2 Step -1
    nMonths = 12 - Cells(Application.ActiveCell.Row, 3).Value
      If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then Rows(lRow).EntireRow.Resize(nMonths).Insert
   Next lRow
End Sub

Please let me know if you have any suggestions.

*All data in these examples is fictional

回答1:

Try this after renaming the referenced worksheet.

Sub expandMonths()
    'https://stackoverflow.com/questions/52304181
    Dim i As Long, j As Long, m As Long, a As Variant

    With Worksheets("sheet1")

        i = .Cells(.Rows.Count, "A").End(xlUp).Row
        Do While i > 1
            a = Array(.Cells(i, "A").Value2, .Cells(i, "B").Value2, 0, 0, 0, 0)
            m = .Cells(i, "C").Value2
            j = Application.Match(.Cells(i, "A").Value2, .Columns("A"), 0)

            If i - j < m Then
                .Rows(j).Resize(m - (i - j) - 1, 1).EntireRow.Insert
                .Cells(j, "A").Resize(m - (i - j) - 1, UBound(a) + 1) = a
                .Cells(j, "C").Resize(m - (i - j) - 1, 4).NumberFormat = "0"
            End If

            i = j - 1
        Loop
    End With

End Sub