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

时间:2019-02-19 22:37:12

标签: excel insert range named-ranges

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

此刻,我有一个does what you see here.

从本质上讲,我有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

结束子

任何帮助将不胜感激。

谢谢!

2 个答案:

答案 0 :(得分:0)

经过测试,工作正常。...


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

答案 1 :(得分:0)

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

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

结束子