需要帮助：将行复制到下面创建的许多行中（Excel VBA）

Question

New user here who is also very new to Excel VB.

At the moment, I have a macro which does what you see here.

Essentially, I have 2 columns which can sometimes have cells which contain vertically stacked lines of data in each cell. Each of those lines is split out and put into newly inserted rows below (one line of data in the cell per row).

The problem I am having now, is that while the new rows now contain data in the two columns which had to be split (34 and 35), the remaining cells are empty. I am having trouble bringing the remaining 38 columns down into the newly-created rows. You can see what I mean in the image I posted. Two new rows were created and I need to fill them with the content of row 1 (fill in to the shaded area).

Here is my code right now. The part that is commented out is me trying to fill the empty space. The un-commented code does what you see in the image.

Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim IDVariables As Range
Dim arr As Variant


With Worksheets("UI").Columns("AH") 
    nRows = .Cells(.Rows.Count, 1).End(xlUp).Row 
    For iRow = nRows To 2 Step -1 
        With .Cells(iRow) 
            arr = Split(.Value, vbLf) 
            nData = UBound(arr) + 1 
            If nData > 1 Then 
                    .EntireRow.Offset(1).Resize(nData - 1).Insert 
                    .Resize(nData).Value = Application.Transpose(arr) 
                    .Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf)) 
                    'Set IDVariables = Range("A" & iRow & ":AG" & iRow)
                    'IDVariables.Select
                    'Selection.Copy
                    'Range("A" & (iRow + 1) & ":A" & (iRow + nData -1)).Select
                    'Selection.Paste             
            End If
        End With
    Next iRow
End With

End Sub

Any help would be very much appreciated.

Thanks!

Answer 1

Tested and working fine....

---

Option Explicit

Sub ReCode()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

Dim LR As Long, i As Long, arr
LR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row

For i = LR To 2 Step -1
    If InStr(ws.Range("AH" & i), vbLf) Then
        ws.Range("A" & i + 1).EntireRow.Insert xlUp
            ws.Range("A" & i).EntireRow.Copy ws.Range("A" & i + 1)
            arr = Split(ws.Range("AH" & i), vbLf)
            ws.Range("AH" & i) = arr(0)
            ws.Range("AH" & i + 1) = arr(1)
        arr = ""
    End If
Next i

End Sub

Answer 2

I'm late doing this but I figured it out. I'll post my solution for anyone who has a similar problem.

Sub main()
Dim iRow As Long, nRows As Long, nData As Long
Dim arr As Variant
Dim IDVariables, Comments, AllocationCheck As Range

Application.ScreenUpdating = False

With Worksheets("PRM2_Computer").Columns("AH")
    nRows = .Cells(.Rows.Count, 1).End(xlUp).Row        
    For iRow = nRows To 2 Step -1
        With .Cells(iRow)
            arr = Split(.Value, vbLf)
            nData = UBound(arr) + 1
            If nData = 1 Then
                Range("AI" & iRow) = 1
                Range("AK" & iRow) = "Single Industry"
            End If
            If nData > 1 Then
                    .EntireRow.Offset(1).Resize(nData - 1).Insert
                    .Resize(nData).Value = Application.Transpose(arr)
                    .Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf))
                    .Offset(, 2).Resize(nData).Value = Application.Transpose(Split(.Offset(, 2).Value, vbLf))
                    Set Comments = Range("AL" & iRow & ":AM" & iRow)
                    Comments.Copy Range("AL" & (iRow + 1) & ":AL" & (iRow + nData - 1))
                    Set AllocationCheck = Range("AK" & (iRow) & ":AK" & (iRow + nData - 1))
                    AllocationCheck.Value = Application.Sum(Range("AI" & iRow & ":AI" & (iRow + nData - 1)))
                    Set IDVariables = Range("A" & iRow & ":AG" & iRow)
                    IDVariables.Copy Range("A" & (iRow + 1) & ":A" & (iRow + nData - 1))
            End If
        End With
    Next iRow
End With

End Sub