Need help looping Makro, das einen Zellenbereich basierend auf einer ausgewählten Zeile ausschneidet/einfügt und löscht

Question

Dieses Makro wird zum Ausschneiden, Einfügen und Löschen eines Zellenbereichs einer Arbeitsmappe verwendet.

Das Problem, das ich lösen wollte und mit der fehlenden Antwort in einem anderen Thread aufgab, ist, warum das Kopieren mehrerer nicht benachbarter Zeilen in die MS-Zwischenablage oft ihre Zeilenumbrüche beim Einfügen verliert.

z. Da versucht wird, 3 nicht benachbarte Zeilen in die Zeilen 10, 11 und 12 einzufügen, werden oft alle 3 Zeilen in Zeile 10 mit einer Zeile in Felder A10-P10, die nächste Zeile in Q10-AF10 und die letzte Zeile in AG10-AV10 gesetzt. ..

Ich habe das Makro unten bearbeitet, um diesen Fehler zu beheben, wenn dies passiert.

So, zum Beispiel kann ich jetzt Zeile 10 hervorheben und das Makro ausführen, um die Felder Q10-AF10 bis A11-P11 auszuschneiden/einzufügen und die leeren Felder jetzt in Q10-AF10 zu löschen/verschieben.

Ich hoffe auf Hilfe, diesen Prozess zu wiederholen, bis keine Daten außerhalb der Spalte A-P vorhanden sind. In diesem Fall keine Daten außerhalb der Zelle P10.

Sub FixAllOnLine1OneRowAtATimeInsertToNextRow() 

Application.ScreenUpdating = False 
    Dim copySheet As Worksheet 
    Dim pasteSheet As Worksheet 

    Set copySheet = ActiveSheet 
    Set pasteSheet = ActiveSheet 

    copySheet.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Copy 
    Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Offset(1).Select 

    pasteSheet.Cells(ActiveCell.Row, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
    Application.CutCopyMode = False 
    Application.ScreenUpdating = True 
    Columns("Q:AF").Select 
    Selection.Delete Shift:=xlToLeft 

End Sub 

Answer 1

Ok, ich machte einige Fortschritte. Ich habe nur ein super einfaches Problem und dann muss ich es wiederholen.

Das erste Problem ist, dass es schneidet Spalte Q: AF korrekt der Reihe, die ich markiert habe und verschiebt die gesamte Spalte Q: AF nach links, aber es fügt die ausgeschnittenen Zellen in den festen Bereich, A2: P2. Ich möchte die ausgeschnittenen Zellen in eine Zeile meiner Auswahl einfügen. Ich weiß, das ist ein paar Zeichen im Offset, ich kann es einfach nicht verstehen.

Dann, sobald es richtig funktioniert ... sagen wir Zeile 10 markieren, schneidet Q10: AF10 und stattdessen die Zellen in A11: P11 und verschiebt "Q: AF" nach links, dann muss ich herausfinden wie man es in eine Schleife bringt, bis sich rechts neben Spalte P keine Daten mehr befinden. Wenn dieses Problem auftritt, wenn mehrere Zeilen aus der Zwischenablage in die erste Zeile eingefügt werden und die Zeilenumbrüche verloren gehen, sind es immer einige Zeilen.

Irgendwelche Ideen?

Thanks so much! Mark

Sub FixAllOnLine1OneRowAtATimeInsertToNextRow() 

    Dim ws As Worksheet 
    Dim lNextRow As Long 

     Application.ScreenUpdating = False 

     Set ws = ActiveSheet 

     ws.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Copy 'Copy the row of the selected cell from Q:AF 

     ws.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Offset(1).Select 'Select the cells you have just copied. Not needed 

     ws.Cells(ActiveCell.Row, 1).End(xlUp).Offset(1, 0).Insert xlShiftDown ' Paste the copied values in to column "A" on next row? 
     'lNextRow = ws.Range("A" & Rows.count).End(xlUp).Row + 1 'Get Next Row number 
     'Range("A" & lNextRow).PasteSpecial xlPasteValues 

     Application.CutCopyMode = False 
     Range("Q:AF").Delete Shift:=xlToLeft 
     'Columns("Q:AF").Select 
     'Selection.Delete Shift:=xlToLeft 

     Application.ScreenUpdating = True 
     ActiveCell.Offset(RowOffset:=-1, columnOffset:=0).Activate 'Added to move active cell up one row to run it again for multiple groups to apply fix. 

    End Sub 

Answer 2

Hier ist eine Lösung in einer anderen Richtung für den Fall, jemand von den Motoren braucht es ...

Sub ReduceNoOfColumns() 

Dim iRow As Integer 'Row to be manipulated 
Dim iRowToPasteTo 'Row number to paste the copied cells 
Dim iCurCol As Integer 'Current Column number of first cell with a value to cut 
Dim NoOfCols As Integer 'integer to hold max number of columns 
Dim sAddress As String 

    iRow = ActiveCell.Row 
    iRowToPasteTo = iRow + 1 
    NoOfCols = 16 'Set this number to the total number of columns you wish to have (in your case 16) 
    iCurCol = NoOfCols + 1 

    Do Until Cells(iRow, iCurCol).Value = "" 'Keep looping until we get to an empty column 
     sAddress = ColNoToLetter(iCurCol) & iRow & ":" & ColNoToLetter(iCurCol + NoOfCols - 1) & iRow 
     Rows(iRowToPasteTo & ":" & iRowToPasteTo).Insert Shift:=xlDown 
     Range(sAddress).Copy 
     Range("A" & iRowToPasteTo).PasteSpecial xlPasteAll 
     Range(sAddress).Clear 

     iCurCol = iCurCol + NoOfCols 
     iRowToPasteTo = iRowToPasteTo + 1 
    Loop 

End Sub 

Function ColNoToLetter(iCol As Integer) As String 
Dim vArr 
vArr = Split(Cells(1, iCol).Address(True, False), "$") 
ColNoToLetter = vArr(0) 
End Function