宏在任何有數據的現有行上面插入一行

Question

我試圖操縱一些VBA來完成這項工作，但是，我似乎沒有得到任何地方。

我想編寫一個宏，在數據的任何行上插入新行，然後將數據從單元格1和2複製到新行中。

我把我有一個圖片，並且我希望有

附加照片圖片：

What I have What I need

這裏是我使用的代碼，但我需要它繼續下行：

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

這實際上可能很棘手。如果您嘗試在同時插入新行的同時迭代一組行，最終會導致無限循環。解決方案是首先將數據行存儲在集合中，然後在插入行和複製數據時迭代該集合。看下面的例子是否適合你。

更新：如果前兩列有值，則將邏輯更改爲僅插入空行。看看這是否有效。

起始狀態：

代碼：

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 

末狀態：

Answer 2

看起來像你應該能夠得到公司的核心通過錄制一個宏。只需打開錄製，插入必要的行&將值複製到新行。那麼你只需要將其泛化即可。如果您還有問題，請立即發佈代碼以獲取更詳細的指導。

更新：這是我怎麼會調整你貼

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 & Selection.，因爲它會顯着減慢您的代碼。