Zeilen und Zellen mit Bedingung zusammenfassen

[lizzard]

noch eine Frage und Beschreibungstext unterscheidet sich wenn die Spalten D, F, H, M gleich sind?

Anders, Spalte E kann einen anderen Text haben, obwohl D,F,H,M gleich sind??

Nein, der Beschreibungstext ist gleich, bzw. den kann ich in der Ergebnistabelle neu aufbauen.

[atilla]

Hallo,

schau mal ob das hinhaut:

Edit im Code Variabele i und j nachträglich deklariert

Code:

Sub zusammenfassen()
Dim i as Long, j as Long
Dim lngZq As Long, lngZz As Long
Dim arr1(), arr2()
Dim feld
Dim cKey
Dim cO As Object

 Set cO = CreateObject("Scripting.Dictionary")
 With Sheets("Tabelle1")
   lngZq = .Cells(.Rows.Count, 1).End(xlUp).Row
   feld = .Range("A1:N" & lngZq)
 End With

 For i = 2 To lngZq
   cKey = feld(i, 13) & "#" & feld(i, 4) & "#" & feld(i, 6) & "#" & feld(i, 8) & "#" & feld(i, 14)
   cO(cKey) = cO(cKey) & "|" & feld(i, 1)
 Next i
 
 ReDim arr1(cO.Count, 1)
 ReDim arr2(cO.Count, 2)
 For Each cKey In cO
   arr1(j, 0) = Split(cKey, "#")(0)
   arr1(j, 1) = Split(cKey, "#")(1)
   arr2(j, 0) = Split(cKey, "#")(2)
   arr2(j, 1) = cO(cKey)
   arr2(j, 2) = CDbl(Split(cKey, "#")(4))
   j = j + 1
 Next
 
 With Sheets("Tabelle2")
   lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Range("A2:F" & lngZz).ClearContents
   .Cells(2, 1).Resize(j, 2).Value = (arr1)
   .Cells(2, 4).Resize(j, 3).Value = (arr2)
 End With
 
End Sub

Damit Du nicht sagst, es passiert nichts, hier das Ergebnis welches ich erhalte:

Arbeitsblatt mit dem Namen 'Tabelle3'
	A	B	C	D	E	F
1	ArtikelNr	name	Description	Marke	Nr	Gewicht
2	444444	Typ1		Alfa Romeo	|100113|100114|100115|100117|100121|100122|100118|100120|100125|100119|100123|100112|100124|100116	18
3	111111	Typ1		Alfa Romeo	|100015|100014|100016|100001|100006|100004|100019|100010|100012|100017|100002|100008|100011|100005|100009|100020|100013|100018|100003|100007	21
4	111111	Typ1		Alfa Romeo	|100038|100058|100021|100039|100040|100023|100045|100043|100026|100050|100048|100032|100030|100054|100033|100034|100035|100055|100041|100046|100028|100052|100036|100056	21
5	111111	Typ2		Alfa Romeo	|100022|100044|100025|100049|100029|100053|100031|100037|100057|100042|100024|100047|100027|100051	21
6	666666	Typ2		Alfa Romeo	|100150|100152|100144|100147|100143|100146|100140|100153|100154|100155|100141|100148|100145|100149|100142|100151	17,6
7	666666	Typ2		Alfa Romeo	|100166|100168|100160|100162|100159|100163|100156|100169|100170|100171|100157|100164|100161|100165|100158|100167	17,6
8	999999	Typ2		Alfa Romeo	|100234|100228|100233|100238|100239|100244|100245	17
9	999999	Typ1		Alfa Romeo	|100231|100232|100242|100229|100237|100240|100227|100230|100235|100236|100241|100243	17
10	555555	Typ1		Alfa Romeo	|100127|100128	19,4
11	555555	Typ2		Alfa Romeo	|100129|100131|100135|100136|100132|100134|100139|100133|100137|100126|100138|100130	19,4
12	222222	Typ2		Alfa Romeo	|100076|100075	23
13	222222	Typ1		Alfa Romeo	|100077|100059|100064|100062|100080|100068|100071|100072|100073|100078|100060|100066|100070|100063|100067|100081|100069|100074|100079|100061|100065	23
14	222222	Typ1		Alfa Romeo	|100105|100082|100083|100088|100086|100093|100091|100099|100097|100100|100101	23
15	222222	Typ2		Alfa Romeo	|100102|100084|100089|100095|100103|100087|100092|100096|100098|100104|100085|100090|100094	23
16	777777	Typ2		Alfa Romeo	|100182|100184|100176|100179|100175|100178|100172|100185|100186|100187|100173|100180|100177|100181|100174|100183	18,6
17	777777	Typ2		Alfa Romeo	|100198|100200|100192|100194|100191|100195|100188|100201|100202|100203|100189|100196|100193|100197|100190|100199	18,6
18	121212	Typ2		Alfa Romeo	|100253|100247|100252|100257|100258|100263|100264|100250|100251|100261	18,2
19	121212	Typ1		Alfa Romeo	|100248|100256|100259|100246|100249|100254|100255|100260|100262	18,2
20	333333	Typ1		Alfa Romeo	|100107|100110|100111|100106|100108|100109	22
21	888888	Typ1		Alfa Romeo	|100209|100225|100206|100205	20,76
22	888888	Typ2		Alfa Romeo	|100216|100221|100226|100210|100222|100204|100212|100215|100218|100219|100220|100224|100207|100208|100211|100214|100223|100213|100217	20,76

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Ich habe das Gewicht mit zur Feststellung der Doppelten genommen.
Wenn das nicht sein soll, muss ich nachsitzen. Wenn Du sicher bist, dass Beschreibung gleich ist, dann kann ich das ohne nachsitzen leicht einbauen.

[lizzard]

@attila: Perfekt - funktioniert einwandfrei!

Wenn ich das Script nun um weitere Felder in der Ausgabe erweitern möchte, was müsste ich da anpassen?

[atilla]

Hallo,

das geht nicht so einfach.
Man muss an mehreren Stellen Änderung vornehmen.

Ich habe den Code jetzt verändert, so dass Du selber beliebige Spalten anpassen kannst.
Schau Dir die Kommentare im Code an, dann wirst Du das System leicht erfassen.

Wichtig!
Ich nutze in Tabelle1 die Spalte O als Hilfsspalte. Dort wird temporär eine Formel rein geschrieben und am Ende wieder entfernt!

Code:

Sub zusammenfassen2()
Dim i As Long, j As Long, x As Long
Dim lngZq As Long, lngZz As Long
Dim arr1(), arr2()
Dim feld, feld2
Dim cKey
Dim cO As Object

 Set cO = CreateObject("Scripting.Dictionary")
 With Sheets("Tabelle1")
   lngZq = .Cells(.Rows.Count, 1).End(xlUp).Row
   .Range("O2:O" & lngZq).FormulaLocal = "=M2&" & """#""" & "&D2&" & """#""" & "&F2&" & """#""" & "&H2"
   feld = .Range("A1:N" & lngZq)
   feld2 = .Range("O1:O" & lngZq)
   .Range("O2:O" & lngZq).ClearContents
 End With

 For i = 2 To lngZq
   cKey = feld(i, 13) & "#" & feld(i, 4) & "#" & feld(i, 6) & "#" & feld(i, 8)
   cO(cKey) = cO(cKey) & "|" & feld(i, 1)
 Next i
 
 ReDim arr(cO.Count, 5)    ' die Zahl gibt die Anzahl der einzulesenden Saplten minus 1 Spalte an

 For Each cKey In cO
   x = Application.Match(cKey, feld2, 0)
   arr(j, 0) = feld(x, 1)     'Artikel-Nr
   arr(j, 1) = feld(x, 4)     'Name
   arr(j, 2) = feld(x, 5)     'Description
   arr(j, 3) = feld(x, 6)     'Marke
   arr(j, 4) = Replace(cO(cKey), "|", "", 1, 1)  'Nummern zusammenfassung
   arr(j, 5) = feld(x, 14)     'Gewicht
   j = j + 1
 Next
 
 With Sheets("Tabelle2")
   lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Range("A2:F" & lngZz).ClearContents
   .Cells(2, 1).Resize(j, 6).Value = (arr)
 End With
 
End Sub

[lizzard]

Hallo,

das geht nicht so einfach.
Man muss an mehreren Stellen Änderung vornehmen.

Ich habe den Code jetzt verändert, so dass Du selber beliebige Spalten anpassen kannst.
Schau Dir die Kommentare im Code an, dann wirst Du das System leicht erfassen.

Wichtig!
Ich nutze in Tabelle1 die Spalte O als Hilfsspalte. Dort wird temporär eine Formel rein geschrieben und am Ende wieder entfernt!

Code:

Sub zusammenfassen2()
Dim i As Long, j As Long, x As Long
Dim lngZq As Long, lngZz As Long
Dim arr1(), arr2()
Dim feld, feld2
Dim cKey
Dim cO As Object

 Set cO = CreateObject("Scripting.Dictionary")
 With Sheets("Tabelle1")
   lngZq = .Cells(.Rows.Count, 1).End(xlUp).Row
   .Range("O2:O" & lngZq).FormulaLocal = "=M2&" & """#""" & "&D2&" & """#""" & "&F2&" & """#""" & "&H2"
   feld = .Range("A1:N" & lngZq)
   feld2 = .Range("O1:O" & lngZq)
   .Range("O2:O" & lngZq).ClearContents
 End With

 For i = 2 To lngZq
   cKey = feld(i, 13) & "#" & feld(i, 4) & "#" & feld(i, 6) & "#" & feld(i, 8)
   cO(cKey) = cO(cKey) & "|" & feld(i, 1)
 Next i
 
 ReDim arr(cO.Count, 5)    ' die Zahl gibt die Anzahl der einzulesenden Saplten minus 1 Spalte an

 For Each cKey In cO
   x = Application.Match(cKey, feld2, 0)
   arr(j, 0) = feld(x, 1)     'Artikel-Nr
   arr(j, 1) = feld(x, 4)     'Name
   arr(j, 2) = feld(x, 5)     'Description
   arr(j, 3) = feld(x, 6)     'Marke
   arr(j, 4) = Replace(cO(cKey), "|", "", 1, 1)  'Nummern zusammenfassung
   arr(j, 5) = feld(x, 14)     'Gewicht
   j = j + 1
 Next
 
 With Sheets("Tabelle2")
   lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Range("A2:F" & lngZz).ClearContents
   .Cells(2, 1).Resize(j, 6).Value = (arr)
 End With
 
End Sub

Hi attila,

vielen Dank jetzt wirds klar Das Erweitern ist nun kein Problem.
Kann es sein dass die Zeile

Code:

.Range("A2:F" & lngZz).ClearContents

nicht notwendig ist?
Noch eine Frage zum Erweitern des Codes: ist es möglich die Spaltenüberschriften aus Tabelle1 mit zu kopieren?

[atilla]

Hallo,

mit der gezeigten Zeile wurden bestehende Daten in der Zieltabelle gelöscht, also sollte drin bleiben.
Dann könntest Du die Überschriften also einmal manuell rüberkopieren, diese würden dann auch belassen.

Möchtest Du aber die Überschriften immer per Code übertragen, dann würde ich den letzten Teil im Code so schreiben:

Code:

 With Sheets("Tabelle2")
   lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Cells.ClearContents
   .Cells(2, 1).Resize(j, 6).Value = (arr)
   .Cells(1, 1).Value = Sheets("Tabelle1").Cells(1, 1).Value 'Zelle A1 in Tabelle2 = Zelle A1 der Tabelle1
   .Cells(1, 2).Value = Sheets("Tabelle1").Cells(1, 2).Value 'Zelle B1 in Tabelle2 = Zelle B1 der Tabelle1
   '...usw
   'wenn zusammenhängendgeht auch
   '.Range("A1:F1").Value = Sheets("Tabelle1")Range("A1:F1").Value
 End With

[BoskoBiati]

Hallo,

hier mal ein Entwurf mit einer Hilfsspalte, habe momentan keine Zeit, das weiter zu bearbeiten.



  typentest-2.xlsx (Größe: 585,35 KB / Downloads: 2)

[lizzard]

Hallo,

mit der gezeigten Zeile wurden bestehende Daten in der Zieltabelle gelöscht, also sollte drin bleiben.
Dann könntest Du die Überschriften also einmal manuell rüberkopieren, diese würden dann auch belassen.

Möchtest Du aber die Überschriften immer per Code übertragen, dann würde ich den letzten Teil im Code so schreiben:

Code:

 With Sheets("Tabelle2")
   lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   .Cells.ClearContents
   .Cells(2, 1).Resize(j, 6).Value = (arr)
   .Cells(1, 1).Value = Sheets("Tabelle1").Cells(1, 1).Value 'Zelle A1 in Tabelle2 = Zelle A1 der Tabelle1
   .Cells(1, 2).Value = Sheets("Tabelle1").Cells(1, 2).Value 'Zelle B1 in Tabelle2 = Zelle B1 der Tabelle1
   '...usw
   'wenn zusammenhängendgeht auch
   '.Range("A1:F1").Value = Sheets("Tabelle1")Range("A1:F1").Value
 End With

Alles klar, Danke dir, werde ich ausprobieren!