Question

我试图操纵一些VBA来使这项工作，但是，我似乎没有到达任何地方。

我想编写一个宏，在数据的任何行上方插入一个新行，然后将数据从单元格1和2复制到该新行中。

我把我所拥有的照片和我想要的照片

其他照片：

这是我使用的代码，但我需要它继续下去：

 Sub InsertRowandCopyCell1and2()
'
' InsertRowandCopyCell1and2 Macro
'
' Keyboard Shortcut: Ctrl+w
'
    Rows("78:78").Select
    Selection.Insert Shift:=xlDown
    Range("A79:B79").Select
    Selection.Cut
    Range("A78").Select
    ActiveSheet.Paste
    Rows("78:78").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -9.99786370433668E-02
        .PatternTintAndShade = 0
    End With
    Rows("92:92").Select
    Selection.Insert Shift:=xlDown
    Range("A93:B93").Select
    Selection.Cut
    Range("A92").Select
    ActiveSheet.Paste
    Rows("92:92").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -9.99786370433668E-02
        .PatternTintAndShade = 0
    End With
    Rows("96:96").Select
    Selection.Insert Shift:=xlDown
    Range("A97:B97").Select
    Selection.Cut
    Range("A96").Select
    ActiveSheet.Paste
    Rows("96:96").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -9.99786370433668E-02
        .PatternTintAndShade = 0
    End With
End Sub

Answer 1

看起来你应该能够通过录制宏来获得代码的核心。只需打开录音，插入必要的行＆amp;将值复制到新行。然后你只需要对它进行泛化。给出一个镜头，如果您仍然遇到问题，请将代码发布，以获得更详细的指导。

更新：这是我如何调整您发布的代码

Sub InsertRowandCopyCell1and2()
'
' InsertRowandCopyCell1and2 Macro
'
' Keyboard Shortcut: Ctrl+w
'
Dim i as Long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets(1) 'change to the correct index or use the sheet's name

'Setup to iterate through the rows. NOTE: I'm assuming your data starts in row 2 & that
'    the data is continuous in Column C (i.e. if C is blank for a row, there is no data
'    from that row down) adjust the macro accordingly
i = 3
Do While ws.Range("C" & i - 1).value <> ""
    'Check if the row has data in columns A & B
    If ws.Range("A" & i - 1).value <> "" And ws.Range("B" & i - 1).Value <> "" Then
        'Prior row has data, insert a new row BELOW the row being checked (thus why we
        '    start on row 3 & look at row i -1
        ws.Rows(i & ":" & i).Insert Shift:=xlDown

        'We've just created a new row i, which we now need to move the data from row i - 1 down into
        ws.Range("C" & i - 1 & ":E" & i - 1).Cut
        ws.Range("C" & i).PasteSpecial xlPasteAll

        'The row we need to check next WAS row i, but due to the insert, it's now row i + 1,
        '    so we simply increment i by 2 (thus skipping looking at row i, the row we just created)
        i = i + 2
    Else
        'Row does not indicate an insertion is necessary, simply  move to the next row
        i = i + 1
    End If
Loop

End Sub

我确实删除了格式更改代码，因为我没有遵循何时执行此操作的逻辑，但您可以通过简单地将其包含在具有正确条件的If语句中来添加它。

侧栏：避免使用Select＆amp;尽可能Selection.因为它会严重降低您的代码速度。

Answer 2

这实际上可能很棘手。如果您在同时插入新行时尝试迭代一组行，则最终会产生无限循环。解决方案是首先将数据行存储在集合中，然后在插入行和复制数据时迭代该集合。看看下面的示例是否适合您。

更新：如果前两列有值，则将逻辑更改为仅插入空行。看看是否有效。

开始状态：

代码：

Sub insertRows()

    ' first you have to store all the rows in a collection,
    ' because if you'll iterate while adding rows your loop
    ' will never end
    Dim rw As Range
    Dim cRows As New Collection
    For Each rw In ActiveSheet.[a1:e11].Rows
        ' only include rows that have first and second cells non-empty
        If Len(Trim(rw.Cells(1))) > 0 And Len(Trim(rw.Cells(2))) > 0 Then
            cRows.Add rw
        End If
    Next

    ' now iterate the immutable collection of rows and copy data
    Dim rng As Variant
    For Each rng In cRows
        rng.EntireRow.Insert
        rng.Cells(1).Cut rng.Cells(1).Offset(-1)
        rng.Cells(2).Cut rng.Cells(2).Offset(-1)
    Next

End Sub

结束状态：

宏在任何包含数据的现有行上方插入一行

2 个答案: