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

Question

这里的新用户对Excel VB也是很新的。

目前，我有一个宏，它可以完成您在此处看到的内容。

本质上，我有2列，有时可以包含一些单元格，其中每个单元格中都包含垂直堆叠的数据行。 这些行中的每一行都被拆分并放入下面新插入的行中（每行单元格中有一行数据）。

我现在遇到的问题是，尽管新行现在在必须拆分的两列（34和35）中包含数据，但其余单元格为空。 我在将其余38列放到新创建的行中时遇到麻烦。 您可以在发布的图片中看到我的意思。 创建了两个新行，我需要用第1行的内容填充它们（填充到阴影区域）。

这是我的代码。 被注释掉的部分是我试图填充空白处。 未注释的代码执行您在图像中看到的内容。

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

结束子

任何帮助将不胜感激。

谢谢！

Answer 1

经过测试，工作正常。

---

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

我迟到了，但是我想通了。 我会将解决方案发布给有类似问题的任何人。

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

结束子