So fügen Sie eine Schleife mit einem Zähler in vba

Ich habe eine Spalte mit IDs in eine Excel-Tabelle namens Tabelle1. Ich habe Daten, das entspricht der IDs in den Spalten rechts von der Spalte a Die Anzahl von Zellen in einer Zeile variiert. Zum Beispiel:

A, B, C, D, E, F, ...

John, 5, 10, 15, 20

Jacob, 2, 3

Jingleheimmer, 5, 10, 11

Ich versuche zu kopieren, die Daten in ein neues Arbeitsblatt, Tabelle5, in dem folgenden format:

A, B, C, D, E, F, ...

John, 5

John, 10

John, 15

John, 20

Jacob, 2

Jacob, 3

Jingleheimmer, 5

Jingleheimmer, 10

Jingleheimmer, 11

Schrieb ich folgenden code, der Kopien in den ersten zwei IDs. Ich könnte weiter kopieren und einfügen der zweiten Hälfte des Codes und ändern Sie einfach die Zellen, allerdings habe ich 100te IDs. Dies würde zu lange dauern. Ich denke, wenn ein Vorgang wird wiederholt, ich sollte mit einer Schleife. Können Sie mir helfen, verwandeln diese sich wiederholenden code in eine Schleife?

Sub Macro5()

Dim LastRowA As Integer
Dim LastRowB As Integer

''' Process of copying over first ID '''

'grab all data cells in B2 to the right
With Sheets("Sheet1").Select
Range("B2", Range("B2").End(xlToRight)).Select
Selection.Copy
End With

'paste that data into the first empty cell of Column B in Sheet5
With Sheets("Sheet5").Select
Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End With

'grab the corresponding ID in cell A2
With Sheets("Sheet1").Select
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
End With

'paste the corresponding ID into the first empty cell of Column A in Sheet5
With Sheets("Sheet5").Select
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("A1:A" & LastRowB)
End With

''' Repeat that process for each row in Sheet1 '''

'grab all data cells in B3 to the right
With Sheets("Sheet1").Select
Range("B3", Range("B3").End(xlToRight)).Select
Selection.Copy
End With

'paste that data into the first empty cell of Column B in Sheet5
With Sheets("Sheet5").Select
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & LastRowB + 1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End With

'grab the corresponding ID in cell A3
With Sheets("Sheet1").Select
Range("A3").Select
Application.CutCopyMode = False
Selection.Copy
End With

'paste the corresponding ID into the first empty cell of column A in Sheet5
'and autofill down to the last populated cell in column B
With Sheets("Sheet5").Select
LastRowA = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRowB + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
Selection.AutoFill Destination:=Range("A" & LastRowA & ":A" & LastRowB)
End With

End Sub

InformationsquelleAutor tulanejosh | 2016-04-07

Versuchen Sie dies:

Sub test()

Dim i As Integer
Dim j As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim nRow As Integer
Dim lRow As Integer
Dim lCol As Integer

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet5")
nRow = 1

With ws1

    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 1 To lRow

        lCol = .Cells(i, .Columns.Count).End(xlToLeft).Column

        For j = 2 To lCol

            ws2.Cells(nRow, 1).Value = .Cells(i, 1).Value
            ws2.Cells(nRow, 2).Value = .Cells(i, j).Value
            nRow = nRow + 1

        Next j

    Next i

End With

End Sub

Läuft es durch jede Zeile in das Blatt ein, das kopieren über die Namen und die zugehörigen Nummern durch die Letzte Spalte mit den Werten in dieser Zeile. Sollten die arbeiten sehr schnell und erfordert keine ständige copy & einfügen.

Wow!!! Das funktionierte wirklich gut und es ist einfach zu. Danke. Tangentiale Frage: Wie bekomme ich aus der basic-zählen lastrows und kopieren/einfügen, um nested loops? Ich kann verstehen, Ihrem code, aber finde es schwer, etwas zu schaffen, ohne Hilfe.

InformationsquelleAutor TheGuyThatDoesn'tKnowMuch

Diese tun sollten, was Sie suchen.

Sub test()
Dim lastrow As Long, lastcol As Long
Dim i As Integer, j as Integer, x as Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet5")

lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
x = 1

With ws1
    For i = 1 To lastrow
        lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column
        For j = 2 To lastcol
            ws2.Cells(x, 1).Value = .Cells(i, 1).Value
            ws2.Cells(x, 2).Value = .Cells(i, j).Value
            x = x + 1
        Next j
    Next i
End With

End Sub

Ich benutzte @TheGuyThatDoesn'tKnowMuch Antwort, aber das funktioniert auch. Danke.
Ha! Nicht schnell genug! Wir kamen mit fast genau der gleichen Lösung wenn also alles gut.
Ihre cells qualifiziert werden sollten, um das richtige Blatt
Gut erkannt. Bearbeitet.
Great minds Harley...great minds 😉

InformationsquelleAutor Harley B

Schreibe einen Kommentar

Du musst angemeldet sein, um einen Kommentar abzugeben.