Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1448to1452
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
VBA Zellinhalte aufteilen
24.09.2015 13:37:25
Zokanta
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

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Zellinhalte aufteilen
24.09.2015 16:11:56
Michael
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

Anzeige
AW: VBA Zellinhalte aufteilen
24.09.2015 17:35:59
Peter
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

Anzeige
AW: VBA Zellinhalte aufteilen
25.09.2015 06:54:05
Zokanta
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

AW: VBA Zellinhalte aufteilen
25.09.2015 08:05:38
Zokanta
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

Anzeige
AW: VBA Zellinhalte aufteilen
25.09.2015 12:46:56
Peter
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

Anzeige
AW: VBA Zellinhalte aufteilen
25.09.2015 13:17:15
Peter
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

AW: VBA Zellinhalte aufteilen
25.09.2015 13:59:02
Peter
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

Anzeige
AW: viel einfachere Lösung
25.09.2015 14:37:19
Peter
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

Anzeige
AW: viel einfachere Lösung
30.09.2015 12:31:49
Zokanta
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

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

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

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

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

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige