Schleife durch Zeilen und Spalten Excel Macro VBA

Question

Ich habe eine Spalte in einem Excel-Blatt mit Daten in diesem Format: aaa, bbbb, ccc, dd, eeee, ... jeder String ist durch ein Komma getrennt ","

ich habe Makro erstellt, welche die Daten in der Spalte A aufteilt und jeder String wird separat in einer neuen Zelle für jede Zeile eingefügt, wie in der Abbildung gezeigt.

Jetzt möchte ich zählen, wie viele gebrauchte Zellen nach der Spalte B und nach dieser Zahl den Wert in der Spalte B in einer separaten Zeile wiederholen und zu jeder Zeile den nächsten Wert in Spalte C, D, E ,. ..

Am Ende das Blatt 2 wird wie folgt aussehen:

ich geschaffen habe, eine Lösung:

For i = 1 To 3 

ActiveWorkbook.Sheets(2).Cells(i, 1).Value = ActiveWorkbook.Sheets(1).Range("B1").Value 
ActiveWorkbook.Sheets(2).Cells(i, 2).Value = ActiveWorkbook.Sheets(1).Cells(1, i + 2).Value 

Next i 

Aber es funktioniert nur, wenn die Spalte A nur eine Zeile hat. Ich habe versucht, Loops mit unterschiedlicher Logik zu verwenden, aber es bringt mir immer noch nicht das richtige Ergebnis. Ich habe Hunderte von Zeilen und es wäre zeitaufwendig, es manuell zu machen. Irgendein Vorschlag bitte. Vielen Dank.

Answer 1

Sub ExtractParts() 
    Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1") 
    Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet2") 
    Dim LastRow As Long: LastRow = wsSrc.UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
    Dim LastCol As Long: LastCol = wsSrc.UsedRange.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 
    Dim i As Long, j As Long, RowCounter As Long: RowCounter = 2 

    With wsDest 
     .Cells(1, 1) = "Order Number" 
     .Cells(1, 2) = "Part Number" 
     For i = 1 To LastRow 
      For j = 3 To LastCol 
       If wsSrc.Cells(i, j) <> "" Then 
        .Cells(RowCounter, 1) = wsSrc.Cells(i, 2) 
        .Cells(RowCounter, 2) = wsSrc.Cells(i, j) 
        RowCounter = RowCounter + 1 
       End If 
      Next j 
     Next i 
    End With 
End Sub 

Answer 2

ist hier ein Ansatz

Sub x() 

Dim r As Long, c As Long 

Application.ScreenUpdating = False 

With Sheets(1) 
    For r = 1 To .Range("B" & Rows.Count).End(xlUp).Row 
     c = .Cells(r, Columns.Count).End(xlToLeft).Column - 2 
     .Cells(r, 2).Copy Sheets(2).Range("A" & Rows.Count).End(xlUp)(2).Resize(c) 
     .Cells(r, 3).Resize(, c).Copy 
     Sheets(2).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True 
    Next r 
End With 

Application.ScreenUpdating = True 

End Sub 

Answer 3

Sie

Sub main() 
    Dim cell As Range 
    Dim var As Variant 

    With CreateObject("Scripting.Dictionary") '<--| instantiate a 'Dictionary' object 
     For Each cell In Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp)) '<-- loop through "Sheet1" column A cells from row 1 down to the last not empty one 
      var = Split(cell.Value, ",") '<--| store current cell content into an array, whose first element will be the 'key' of the dictionary 
      .item(var(0)) = Split(Replace(cell.Value, var(0) & ",", "", , 1), ",") '<--| update current 'key' dictionary item with the array of "remaining" values 
     Next 
     For Each var In .Keys '<--| loop through dictionary keys 
      Set cell = Worksheets("Sheet2").cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(.item(var)) + 1) '<--| set "Sheet2" range to start writing the current key values from 
      cell.Value = var '<--| write key 
      cell.Offset(, 1).Value = Application.Transpose(.item(var)) '<--| write current key values 
     Next 
    End With '<--| release 'Dictionary' object 
End Sub 

Answer 4

einen Dictionary Ansatz nutzen könnten Es ist bereits als beantwortet markiert, aber ich fand diese Frage interessant. Also, hier ist mein Beitrag. Dieser Code benötigt nicht die ursprüngliche Aufteilung in mehrere Spalten, sondern nur die eine Spalte mit den durch Komma getrennten Daten.

Dim rng As Range 
Dim x As Variant 
Dim i As Long 
Dim offs As Long 

offs = 1 

Sheet2.Range("A1").Value = "Order Number" 
Sheet2.Range("B1").Value = "Part Number" 

For Each rng In Sheet1.Range("A:A") 

    If Trim(rng.Value) = "" Then End 

    x = Split(rng.Text, ",") 

    For i = 1 To UBound(x) 

     Sheet2.Range("A1").Offset(offs).Value = x(0) 
     Sheet2.Range("B1").Offset(offs).Value = x(i) 
     offs = offs + 1 

    Next i 

Next rng