Makro, um eine Zeile über jeder vorhandenen Zeile einzufügen, die Daten enthält

Question

Ich habe versucht, einige VBA zu manipulieren, um diese Arbeit zu machen, aber, ich scheint nicht überall zu bekommen.

Ich möchte ein Makro schreiben, das eine neue Zeile über jeder Zeile mit Daten einfügt und dann die Daten aus Zelle 1 und 2 in diese neue Zeile kopiert.

habe ich ein Bild von dem, was ich habe, und ein Bild von dem, was ich

Zusätzliche Fotos haben wollen:

What I have What I need

Hier ist der Code, den ich verwendet, aber ich muss es weiter auf der Linie:

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

Dies kann tatsächlich schwierig sein. Wenn Sie versuchen, eine Reihe von Zeilen zu iterieren, während Sie gleichzeitig eine neue Zeile einfügen, erhalten Sie eine Endlosschleife. Die Lösung besteht darin, zuerst Datenzeilen in einer Auflistung zu speichern und dann beim Einfügen von Zeilen und Kopieren von Daten diese Auflistung zu durchlaufen. Sehen Sie, ob das folgende Beispiel für Sie funktioniert.

Update: Die Logik wurde so geändert, dass nur die leere Zeile eingefügt wird, wenn die ersten zwei Spalten einen Wert haben. Sehen Sie, ob das funktioniert.

Startzustand:

Code:

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 

End Zustand:

Answer 2

Scheint wie Sie sollten in der Lage sein, den Kern der co zu bekommen de durch Aufnahme eines Makros. Einfach die Aufnahme einschalten, die erforderliche Zeile einfügen & die Werte in die neue Zeile kopieren. Dann müssen Sie es nur generalisieren. Geben Sie das, und wenn Sie immer noch Probleme haben, geben Sie den Code so ein, wie Sie ihn haben, um detailliertere Anleitungen zu erhalten.

Update: Hier ist, wie ich den Code optimieren würden Sie auf dem Laufenden

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 

Ich habe das Format zu verändern Code Streifen aus, da ich nicht die Logik auf folgende wurde, als das zu tun, aber Sie können hinzufügen es zurück, indem Sie es einfach mit einer If Anweisung, die die richtige Bedingung hat.

Side Bar: Vermeiden Sie Select & Selection., wo immer möglich, da es deutlich Code verlangsamt.