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

Question

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

目前，我有一个宏 does what you see here.

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

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

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

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

我迟到了，但我想通了。我会 post 我的解决方案供遇到类似问题的任何人使用。

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

结束子

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

Need Help: Copying Row Into Many Rows Created below (Excel VBA)

excel

insert

range

named-ranges