VBA Zellinhalte aufteilen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: VBA Zellinhalte aufteilen
von: Zokanta
Geschrieben am: 24.09.2015 13:37:25

Hallo zusammen,
ich habe eine Tabelle bestehend aus zwei Spalten. Exemplarisch steht in der ersten Spalte eine 5-stellige Artikelnummer, in der zweiten Spalte mehrere durch Kommas getrennte Kundennummern:
A B
12345 987654,876543,765432
23456 456123,896523
34567 564789,254987,365478,235987,297364
Mit folgendem Makro teile ich die Kundennummern auf einzelne Zellen auf und lasse ein _ Tabellenblatt einfügen, in dem in Spalte A alle Kundennummern ohne Duplikate untereinander eingefügt werden:


Sub KdNr()
Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1)
    Cells.EntireColumn.AutoFit
    Rows("1:1").Delete Shift:=xlUp
    Range("B1").Select
Dim c As Range, oMat As Object
Set oMat = CreateObject("scripting.dictionary")
For Each c In Range("B:Z").SpecialCells(xlCellTypeConstants)
If Not oMat.exists(c.Value) Then oMat.Add c.Value, ""
Next c
ActiveWorkbook.Worksheets.Add.Name = "Tabelle1"
Sheets("Tabelle1").Cells(1, 1).Resize(oMat.Count) = Application.Transpose(oMat.keys)
Columns("B:B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortTextAsNumbers
        Rows("1:1").Insert Shift:=xlDown
End Sub

Wie muss das Makro verändert werden, um die jeweilige Artikelnummer aus Spalte A mit in das neue Tabellenblatt zu übertragen?
Im Zielbild soll also in dem neu angelegten Tabellenblatt in Spalte A die Artikelnummer stehen und in Spalte B eine Kundennummer:
A B
12345 987654
12345 876543
12345 765432
23456 456123
23456 896523
usw.
Hierbei sollen die Kombinationen aus Spalte A und B jeweils unique sein, also keine Dopplungen aufweisen.
Ich bin für eure Hilfe sehr dankbar.
Gruß
Axel

Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Michael
Geschrieben am: 24.09.2015 16:11:56
Hallo Axel,
die beiden Kundennummern in der mittleren Zeile werden als Dezimalzahl interpretiert; ein anderes Trennzeichen wie z.B. ein ";" wäre vielleicht sinnvoller.
Aber egal, probiere mal das:

Option Explicit
Sub KdNr()
Dim oMat As Object, i&, j&, bis&, a1, a2  ' wird array
bis = Range("A" & Rows.Count).End(xlUp).Row
a1 = Range("A2:B" & bis)
Set oMat = CreateObject("scripting.dictionary")
For i = LBound(a1, 1) To UBound(a1, 1)
  a2 = Split(a1(i, 2), ",")
  For j = LBound(a2) To UBound(a2)
   oMat(a1(i, 1) & "-" & a2(j)) = ""
  Next
Next
MsgBox oMat.Count    ' rein informativ
'ActiveWorkbook.Worksheets.Add.Name = "Ergebnisse"
Sheets("Ergebnisse").Cells(1, 1).Resize(oMat.Count) = Application.Transpose(oMat.keys)
'Columns("B:B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
'        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
'        DataOption1:=xlSortTextAsNumbers
'        Rows("1:1").Insert Shift:=xlDown
End Sub
Damit werden eindeutige WertePAARE geschrieben, wobei die Lösung nicht ganz fertig ist - die Ausgabe erfolgt in *einer* Spalte, aber bei Deinem Level kannst Du die ja selbst auseinanderdröseln.
Schöne Grüße,
Michael

Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Peter Feustel
Geschrieben am: 24.09.2015 17:35:59
Hallo Axel,
hier eine komplett-Lösung, allerdings mit fest vorgegebenem Ergebnis-Tabellenblatt.
Gruß Peter

Option Explicit
Public Sub Artikel_KdNr()
Dim MyDict     As Object   ' das Dictionary
Dim vTemp      As Variant  ' die Eingabe-Daten als temporärer Array
Dim iIndx      As Integer  ' For/Next Schleifen-Index
Dim vKunde     As Variant  ' die durch Komma getrennten Kunden als Array
Dim iKunde     As Integer  ' For/Next Schleifen-Index zum Kunden-Array
Dim vErgebnis  As Variant  ' die Dictionary-Daten als Array
Dim lZeile     As Long     ' der Ausgabe Zeilen-Zähler
 
   Set MyDict = CreateObject("Scripting.Dictionary")
   
   Application.ScreenUpdating = False ' kein Bildschirm-Update
 
'     die Eingabe-Daten in ein Array speichern -> bessere Performance
   With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen
      vTemp = .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   End With
   
   For iIndx = LBound(vTemp, 1) To UBound(vTemp, 1)
      vKunde = Split(vTemp(iIndx, 2), ",")
      For iKunde = LBound(vKunde) To UBound(vKunde)
'           zu jeder Artikel-Nummer, die Kunden-Nummer durch "-" getrennt speichern
         MyDict(Trim$(vTemp(iIndx, 1)) & "-" & Trim$(vKunde(iKunde))) = ""
      Next iKunde
   Next iIndx
      
'     die Dictionary-Daten zum Ausgeben in ein Array kopieren
   vErgebnis = MyDict.keys
   
'     die Artikel- und Kunden-Nummern am "-" wieder zerlegen
   With ThisWorkbook.Worksheets("Ergebnisse") ' den Tabellenblattnamen ggf. anpassen
'         den Ausgabe-Bereich löschen/leeren
      .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
      For iIndx = 0 To UBound(vErgebnis)
         vTemp = Split(vErgebnis(iIndx), "-")
         lZeile = lZeile + 1
         .Range("A" & lZeile).Value = vTemp(0) ' Kunden-Nummer
         .Range("B" & lZeile).Value = vTemp(1) ' Artikel- Nummer
      Next iIndx
   End With
   
   Application.ScreenUpdating = True ' den Bildschirm-Update wieder zulassen
   Set MyDict = Nothing ' die Ressorce wieder freigeben
 
End Sub


Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Zokanta
Geschrieben am: 25.09.2015 06:54:05
Hallo zusammen,
vielen Dank an euch beide. Ich habe den Code von Peter genommen. "ThisWorkbook" gegen "ActiveWorkbook" ausgetauscht lief er dann auch.
Ich habe noch Änderungen an der Ursprungsdatei vornehmen müssen, konnte das aber im Makro verarzten.
Tolles Forum, schnelle und kompetente Hilfe. Super!
Beste Grüße
Axel

Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Zokanta
Geschrieben am: 25.09.2015 08:05:38
Peter, ich brauch' doch noch mal Dein Know How, wenn möglich:
Wie muss Dein Code ergänzt werden, wenn in der Ursprungstabelle weitere Spalten hinzukommen?
Also Spalte A und B bleiben wie zuvor definiert. In Spalte C kommt eine weitere Identifikationsnummer hinzu und in Spalte D ein Datum.
Die Werte aus den Spalten C und D sollen analog der Spalte A behandelt werden, also wenn in Spalte B mehrere Kundennummern stehen, soll in der Ergebnistabelle je ein Datensatz mit der Artikelnummer, dieser Ident Nr und dem Datum aufgeführt werden.
Ich sag schon mal ein dickes Dankeschön!
Axel

Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Peter Feustel
Geschrieben am: 25.09.2015 12:46:56
Hallo Axel,
dann versuche es mit der beigefügten Version.
Ich hoffe, die erfüllt deine Wünsche.
Gruß Peter

Public Sub Artikel_KdNr()
Dim MyDict     As Object   ' das Dictionary
Dim vTemp      As Variant  ' die Eingabe-Daten als temporärer Array
Dim iIndx      As Integer  ' For/Next Schleifen-Index
Dim vKunde     As Variant  ' die durch Komma getrennten Kunden als Array
Dim iKunde     As Integer  ' For/Next Schleifen-Index zum Kunden-Array
Dim vErgebnis  As Variant  ' die Dictionary-Daten als Array
Dim lZeile     As Long     ' der Ausgabe Zeilen-Zähler
 
   Set MyDict = CreateObject("Scripting.Dictionary")
   
   Application.ScreenUpdating = False ' kein Bildschirm-Update
 
'     die Eingabe-Daten in ein Array speichern -> bessere Performance
   With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen
      vTemp = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   End With
   
   For iIndx = LBound(vTemp, 1) To UBound(vTemp, 1)
      vKunde = Split(vTemp(iIndx, 2), ",")
      For iKunde = LBound(vKunde) To UBound(vKunde)
'           zu jeder Artikel-Nummer, die Kunden-Nummer durch "##" getrennt speichern
         MyDict(Trim$(vTemp(iIndx, 1)) & "##" & Trim$(vTemp(iIndx, 3)) & "##" & Trim$(vTemp( _
iIndx, 4)) & "##" & Trim$(vKunde(iKunde))) = ""
      Next iKunde
   Next iIndx
      
'     die Dictionary-Daten zum Ausgeben in ein Array kopieren
   vErgebnis = MyDict.keys
   
'     die Artikel- und Kunden-Nummern am "##" wieder zerlegen
   With ThisWorkbook.Worksheets("Ergebnisse") ' den Tabellenblattnamen ggf. anpassen
'         den Ausgabe-Bereich löschen/leeren
      .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
      For iIndx = 0 To UBound(vErgebnis)
         vTemp = Split(vErgebnis(iIndx), "##")
         lZeile = lZeile + 1
         .Range("A" & lZeile).Value = vTemp(0) ' Kunden-Nummer
         .Range("B" & lZeile).Value = vTemp(3) ' Artikel- Nummer
         .Range("C" & lZeile).Value = vTemp(1) ' Artikel- Nummer
         .Range("D" & lZeile).Value = vTemp(2) ' Artikel- Nummer
      Next iIndx
'         die Ausgabe-Daten aufsteigend sowohl Artikel- als auch Kunden-Nummer sortieren
      .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).Sort _
         Key1:=.Range("A1"), Order1:=xlAscending, _
         Key2:=.Range("B1"), Order2:=xlAscending, _
         Header:=xlNo, OrderCustom:=1, _
         MatchCase:=False, Orientation:=xlTopToBottom
   End With
   
   Application.ScreenUpdating = True ' den Bildschirm-Update wieder zulassen
   Set MyDict = Nothing ' die Ressorce wieder freigeben
 
End Sub


Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Peter Feustel
Geschrieben am: 25.09.2015 13:17:15
Hallo Alex,
mir scheint, mein Schnellschuss funktioniert nicht.
Vergiss ihn also.
Vielleicht komme ich später noch dazu eine Lösung zu finden.
Gruß Peter

Bild

Betrifft: AW: VBA Zellinhalte aufteilen
von: Peter Feustel
Geschrieben am: 25.09.2015 13:59:02
Hallo Axel,
dies könnte die richtige Variante sein.
Gruß Peter

Public Sub Artikel_KdNr()
Dim MyDict     As Object   ' das Dictionary
Dim vTemp      As Variant  ' die Eingabe-Daten als temporärer Array
Dim iIndx      As Integer  ' For/Next Schleifen-Index
Dim vKunde     As Variant  ' die durch Komma getrennten Kunden als Array
Dim iKunde     As Integer  ' For/Next Schleifen-Index zum Kunden-Array
Dim vErgebnis  As Variant  ' die Dictionary-Daten als Array
Dim lZeile     As Long     ' der Ausgabe Zeilen-Zähler
Dim vfix       As Variant  ' die Spalten A, C und D
Dim sKunde     As String   ' die fixe Kunden-Nr
Dim sSpalteC   As String   ' die fixe Spalte C
Dim sSpalteD   As String   ' die fixe Spalte D
Dim iPosit     As Integer  ' die ## im vFix(29
 
   Set MyDict = CreateObject("Scripting.Dictionary")
   
   Application.ScreenUpdating = False ' kein Bildschirm-Update
 
'     die Eingabe-Daten in ein Array speichern -> bessere Performance
   With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen
      vTemp = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   End With
   
   For iIndx = LBound(vTemp, 1) To UBound(vTemp, 1)
      vKunde = Split(vTemp(iIndx, 2), ",")
      For iKunde = LBound(vKunde) To UBound(vKunde)
'           zu jeder Artikel-Nummer, die Kunden-Nummer durch "##" getrennt speichern
         MyDict(Trim$(vTemp(iIndx, 1)) & "++" & Trim$(vTemp(iIndx, 3)) & "++" & Trim$(vTemp( _
iIndx, 4)) & "##" & Trim$(vKunde(iKunde))) = ""
      Next iKunde
   Next iIndx
      
'     die Dictionary-Daten zum Ausgeben in ein Array kopieren
   vErgebnis = MyDict.keys
   
'     die Artikel- und Kunden-Nummern am "##" wieder zerlegen
   With ThisWorkbook.Worksheets("Ergebnisse") ' den Tabellenblattnamen ggf. anpassen
'         den Ausgabe-Bereich löschen/leeren
      .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
      For iIndx = 0 To UBound(vErgebnis)
         vfix = Split(vErgebnis(iIndx), "++")
         sKunde = vfix(0)
         sSpalteC = vfix(1)
         iPosit = InStr(vfix(2), "##")
         sSpalteD = Left(vfix(2), iPosit - 1)
         vTemp = Split(vfix(2), "##")
         lZeile = lZeile + 1
         .Range("A" & lZeile).Value = sKunde   ' Kunden-Nummer
         .Range("B" & lZeile).Value = vTemp(1) ' Artikel- Nummer
         .Range("C" & lZeile).Value = sSpalteC ' Spalte C
         .Range("D" & lZeile).Value = sSpalteD ' Spalte D
      Next iIndx
'         die Ausgabe-Daten aufsteigend sowohl Artikel- als auch Kunden-Nummer sortieren
      .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).Sort _
         Key1:=.Range("A1"), Order1:=xlAscending, _
         Key2:=.Range("B1"), Order2:=xlAscending, _
         Header:=xlNo, OrderCustom:=1, _
         MatchCase:=False, Orientation:=xlTopToBottom
   End With
   
   Application.ScreenUpdating = True ' den Bildschirm-Update wieder zulassen
   Set MyDict = Nothing ' die Ressorce wieder freigeben
 
End Sub


Bild

Betrifft: AW: viel einfachere Lösung
von: Peter Feustel
Geschrieben am: 25.09.2015 14:37:19
Hallo Axel,
manchmal denkt man viel zu kompliziert, dabei ist die Lösung so viel einfacher, wie hier

Public Sub Artikel_KdNr_II()
Dim MyDict     As Object   ' das Dictionary
Dim vTemp      As Variant  ' die Eingabe-Daten als temporärer Array
Dim iIndx      As Integer  ' For/Next Schleifen-Index
Dim vKunde     As Variant  ' die durch Komma getrennten Kunden als Array
Dim iKunde     As Integer  ' For/Next Schleifen-Index zum Kunden-Array
Dim vErgebnis  As Variant  ' die Dictionary-Daten als Array
Dim lZeile     As Long     ' der Ausgabe Zeilen-Zähler
 
 
   Set MyDict = CreateObject("Scripting.Dictionary")
   
   Application.ScreenUpdating = False ' kein Bildschirm-Update
 
'     die Eingabe-Daten in ein Array speichern -> bessere Performance
   With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen
      vTemp = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   End With
   
   For iIndx = LBound(vTemp, 1) To UBound(vTemp, 1)
      vKunde = Split(vTemp(iIndx, 2), ",")
      For iKunde = LBound(vKunde) To UBound(vKunde)
'           zu jeder Artikel-Nummer, die Kunden-Nummer durch "##" getrennt speichern
         MyDict(Trim$(vTemp(iIndx, 1)) & "##" & Trim$(vTemp(iIndx, 3)) & "##" & Trim$(vTemp( _
iIndx, 4)) & "##" & Trim$(vKunde(iKunde))) = ""
      Next iKunde
   Next iIndx
      
'     die Dictionary-Daten zum Ausgeben in ein Array kopieren
   vErgebnis = MyDict.keys
   
'     die Artikel- und Kunden-Nummern am "##" wieder zerlegen
   With ThisWorkbook.Worksheets("Ergebnisse") ' den Tabellenblattnamen ggf. anpassen
'         den Ausgabe-Bereich löschen/leeren
      .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
      For iIndx = 0 To UBound(vErgebnis)
         vTemp = Split(vErgebnis(iIndx), "##")
         lZeile = lZeile + 1
         .Range("A" & lZeile).Value = vTemp(0) ' Kunden-Nummer
         .Range("B" & lZeile).Value = vTemp(3) ' Artikel-Nummer
         .Range("C" & lZeile).Value = vTemp(1) ' Ident-Nummer
         .Range("D" & lZeile).Value = vTemp(2) ' Datum
      Next iIndx
'         die Ausgabe-Daten aufsteigend sowohl Artikel- als auch Kunden-Nummer sortieren
      .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).Sort _
         Key1:=.Range("A1"), Order1:=xlAscending, _
         Key2:=.Range("B1"), Order2:=xlAscending, _
         Header:=xlNo, OrderCustom:=1, _
         MatchCase:=False, Orientation:=xlTopToBottom
   End With
   
   Application.ScreenUpdating = True ' den Bildschirm-Update wieder zulassen
   Set MyDict = Nothing ' die Ressorce wieder freigeben
 
End Sub

Gruß Peter

Bild

Betrifft: AW: viel einfachere Lösung
von: Zokanta
Geschrieben am: 30.09.2015 12:31:49
Hi Peter,
ich habe nur kleine Änderungen vorgenommen, so funktioniert es, vielen Dank nochmals.
Eine letzte Frage noch:
In Spalte C der Ursprungstabelle sind die Inhalte als Standard formatiert, teilweise haben die Werte vorangestellt Nullen. Nach Übertrag ist der Zellinhalt in ein unleserliches Format konvertiert,
z.B.
vorher: 01179545246128917
nachher: 1,17954E+14
Wie kriegt man die Kuh denn noch vom Eis?
Besten Dank
Axel

Bild

Betrifft: AW: viel einfachere Lösung
von: Peter Feustel
Geschrieben am: 30.09.2015 15:04:28
Hallo Axel,
wenn du die Spalte C in der Ausgabe als Text formatierst, solltest du deine Werte richtig ausgegeben bekommen.
Gruß Peter

Bild

Betrifft: AW: viel einfachere Lösung
von: Zokanta
Geschrieben am: 30.09.2015 12:47:04
Und sorry, um es 100%ig perfekt zu machen:
Wie kann ich die Spaltenüberschriften mit in das Dictionary übertragen?
Danke und Gruß
Axel

Bild

Betrifft: AW: viel einfachere Lösung
von: Peter Feustel
Geschrieben am: 30.09.2015 14:56:19
Hallo Axel,
die Überschriften übernehmen geht gar nicht per Dictionary das musst du separat machen.
Gruß Peter

Bild

Betrifft: AW: viel einfachere Lösung
von: Zokanta
Geschrieben am: 30.09.2015 15:06:07
OK, danke Dir!

 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA Zellinhalte aufteilen"