VBA 如果不为空，则将单元格内容复制到下一行的单元格中

Question

我在 A 到 H 列中有数据。某些行在 H 中有数据。如果 HI 中有数据需要在下一行之前插入一行并将 H 的内容复制到新行到单元格 F 中。

我发现的所有示例代码都希望将数据放在表末尾的下一个打开的行中。

如果 H 不为空，我找到了插入一行的代码。

如果不是空白，我需要一些东西将 H 复制到下一行并复制到 F 列的单元格中。

到目前为止我所做的：

Sub SetupData()
    'This copies specific cells from PasteDataHere worksheet
    Application.ScreenUpdating = False

    Dim s1 As Excel.Worksheet
    Dim s2 As Excel.Worksheet
    Dim iLastCellS2 As Excel.Range
    Dim iLastRowS1 As Long

    Set s1 = Sheets("PasteDataHere")
    Set s2 = Sheets("Step1")

    ' get last row of H in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "H").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "A").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("H1", s1.Cells(iLastRowS1, "H")).Copy iLastCellS2

    ' get last row of I in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "I").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "B").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("I1", s1.Cells(iLastRowS1, "I")).Copy iLastCellS2
    
    ' get last row of K in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "K").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "C").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("K1", s1.Cells(iLastRowS1, "K")).Copy iLastCellS2
    
    ' get last row of M in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "M").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "D").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("M1", s1.Cells(iLastRowS1, "M")).Copy iLastCellS2
    
    ' get last row of N in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "N").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "E").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("N1", s1.Cells(iLastRowS1, "N")).Copy iLastCellS2
    
    ' get last row of E in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "E").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "F").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("E1", s1.Cells(iLastRowS1, "E")).Copy iLastCellS2
    
    ' get last row of G in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "G").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "G").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("G1", s1.Cells(iLastRowS1, "G")).Copy iLastCellS2
   
    ' get last row of H in PasteDataHere
    iLastRowS1 = s1.Cells(s1.Rows.Count, "S").End(xlUp).Row

    ' get last AVAILABLE cell to past into
    Set iLastCellS2 = s2.Cells(s2.Rows.Count, "H").End(xlUp).Offset(0, 0)

    'copy into Step1
    s1.Range("S1", s1.Cells(iLastRowS1, "S")).Copy iLastCellS2

    Application.ScreenUpdating = True
    
    'this step puts a space below any row that has data in "H"
    Dim rng As Range
    For Each rng In Range("H1:H62555")
        If Not IsEmpty(rng) Then
            rng.Offset(1, 0).EntireRow.Insert
        End If
    Next

End Sub

Answer 1

下面的答案完全基于您的问题，而不是您提供的代码。 它基于 Sheet1 中的数据 - 根据需要进行更改。

插入行时，您需要自下而上工作 - 否则您定义的范围（随插入的每一行而变化）会将您的代码抛出。

试试这个，让我知道你的 go。

Option Explicit

Sub SetUpData()

Dim ws1 As Worksheet
Dim Lastws1 As Long, i As Long
Dim Rng As Range
Application.ScreenUpdating = False

Set ws1 = ThisWorkbook.Worksheets("Sheet1") '<~~ change sheet name to suit

Lastws1 = ws1.Cells(Rows.Count, "H").End(xlUp).Row

Set Rng = Sheet1.Range("H2:H" & Lastws1)

For i = Lastws1 To 1 Step -1
    
    If Rng.Item(i) <> "" Then
            Rng.Item(i).Offset(1, 0).EntireRow.Insert shift:=xlDown
            Rng.Item(i).Offset(1, -2) = Rng.Item(i).Value
    End If

Next i

Application.ScreenUpdating = True

End Sub