Tabelle Zusammenschieben mit unterschiedlichem Inhalt

[aLtheHeinz]

Liebe Helfende,

Ich bemühe mich in einer Literaturrecherche und habe eine Tabelle mit über 800 Ergebnissen aus einer Onlinesuche erhalten, die meine Ergebnisse enthält, welche ich auswerten muss. Jetzt ist das Problem, dass diese Tabelle recht umständlich organisiert ist und jedes Ergebnis viele Zeilen im Excel verwendet. Ich habe ein etwas übersichtlicheres Beispiel davon erstellt. Es wäre super wenn Ihr mir helfen könntet, wie ich mit gewissen Arbeitsschritten alle 800 Ergebnisse zusammen zu fassen mit einer Zeile pro Ergebnis ohne jedes händisch kopieren zu müssen.

Das Beispiel ist im Anhang dieser Nachricht.


Liebe Grüße und schon mal vielen Dank für Eure Gedanken,

Martin

[atilla]

Hallo,

stell bitte eine Beispielmappe ein. (kein Bild!)

Nee, ist gut brauchst Du doch nicht.
Damit ich das nicht nachbauen muss, habe ich mir eine Software gekauft, die aus Bildern die Daten in eine Excel Tabelle schreiben kann.  

Und wenn ich alles richtig gemacht habe, müsste unten stehender Code Deinen Wünschen entsprechen.
Die Leere Spalte am Ende spare ich mir.

Schau mal ob das von mir Zusammengeschusterte bei Dir auch hinhaut:

Code:

Option Explicit

Sub zusammenfassen()
Dim i As Long, j As Long
Dim lngZq As Long, lngZz As Long
Dim arr1()
Dim feld
Dim cKey
Dim cEF As Object, cG As Object, cJ As Object, cK As Object, cL As Object

  Set cEF = CreateObject("Scripting.Dictionary")
  Set cG = CreateObject("Scripting.Dictionary")
  Set cJ = CreateObject("Scripting.Dictionary")
  Set cK = CreateObject("Scripting.Dictionary")
  Set cL = CreateObject("Scripting.Dictionary")
 
  With Sheets("Tabelle1")
    lngZq = .Cells(.Rows.Count, 1).End(xlUp).Row
    feld = .Range("A1:M" & lngZq)
  End With

  For i = 2 To lngZq
    cKey = feld(i, 1) & "#" & feld(i, 2) & "#" & feld(i, 3) & "#" & feld(i, 4) _
             & "#" & feld(i, 8) & "#" & feld(i, 9) & "#" & feld(i, 13)
    If feld(i, 5) <> "" Or feld(i, 6) <> "" Then cEF(cKey) = cEF(cKey) & feld(i, 5) & "," & feld(i, 6)
    If feld(i, 7) <> "" Then cG(cKey) = cG(cKey) & feld(i, 7)
    If feld(i, 10) <> "" Then cJ(cKey) = cJ(cKey) & ", " & feld(i, 10)
    If feld(i, 11) <> "" Then cK(cKey) = cK(cKey) & ", " & feld(i, 11)
    If feld(i, 12) <> "" Then cL(cKey) = cL(cKey) & ", " & feld(i, 12)
  Next i
 
  ReDim arr1(cEF.Count, 11)
  For Each cKey In cEF
    arr1(j, 0) = Split(cKey, "#")(0)
    arr1(j, 1) = Split(cKey, "#")(1)
    arr1(j, 2) = Split(cKey, "#")(2)
    arr1(j, 3) = Split(cKey, "#")(3)
    arr1(j, 4) = Replace(cEF(cKey), ",", "")
    arr1(j, 5) = cG(cKey)
    arr1(j, 6) = Split(cKey, "#")(4)
    arr1(j, 7) = Split(cKey, "#")(5)
    arr1(j, 8) = Replace(Replace(Trim(Replace(cJ(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 9) = Replace(Replace(Trim(Replace(cK(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 10) = Replace(Replace(Trim(Replace(cL(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 11) = Split(cKey, "#")(6)
    j = j + 1
  Next
 
  'Ergebnisse werden in Tabelle2 geschrieben
  With Sheets("Tabelle2")
    lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    .Range("A2:L" & lngZz).ClearContents
    .Cells(2, 1).Resize(j, 12).Value = arr1
  End With
 
End Sub

Wenn nicht, dann bitte doch eine Beispielmappe einstellen, und ich schmeiß die gekaufte Software in Tonne.

[aLtheHeinz]

Hey Attila,


WOW dankeschön. Sorry für meine späte Antwort... ich dachte ich hatte meinen Account so eingestellt, dass ich benachrichtigt werde aber dem ist scheinbar nicht so. Jetzt hab ich aus Verzweiflung nachgeschaut und mit mit Überraschung Deine Antwort gelesen.

Es kommt ein Fehler heraus, wobei ich mir nicht ganz sicher bin ob ich das Marko richtig angewendet habe. Ich kenne mich mit Markos in Excel eigentlich gar nicht aus:

"
Laufzeitfehler 9

Index außerhalb des gültigen Bereiches.
"

Im Anhang ist meine Beispieldatei.


Liebe Grüße,

aL

[atilla]

Hallo,

in der Datei müssen zwei Tabellen sein.
Tabelle1 ist die Datentabelle, Deine Beispieltabelle.
Dann muss sich noch eine zweite Tabelle in der Datei befinden und diese muss Tabelle2 heißen.
In diese Tabelle2 werden die Ergebnisse dann geschrieben.

Code:

Sub zusammenfassen()
Dim i As Long, j As Long
Dim lngZq As Long, lngZz As Long
Dim arr1()
Dim feld
Dim cKey
Dim cEF As Object, cG As Object, cJ As Object, cK As Object, cL As Object

  Set cEF = CreateObject("Scripting.Dictionary")
  Set cG = CreateObject("Scripting.Dictionary")
  Set cJ = CreateObject("Scripting.Dictionary")
  Set cK = CreateObject("Scripting.Dictionary")
  Set cL = CreateObject("Scripting.Dictionary")

  With Sheets("Tabelle1")
    lngZq = .Cells(.Rows.Count, 1).End(xlUp).Row
    feld = .Range("A1:M" & lngZq)
  End With

  For i = 2 To lngZq
    cKey = feld(i, 1) & "#" & feld(i, 2) & "#" & feld(i, 3) & "#" & feld(i, 4) _
             & "#" & feld(i, 8) & "#" & feld(i, 9) & "#" & feld(i, 13)
    cEF(cKey) = cEF(cKey) & "," & Trim(feld(i, 5) & feld(i, 6))
    If feld(i, 7) <> "" Then cG(cKey) = cG(cKey) & feld(i, 7)
    If feld(i, 10) <> "" Then cJ(cKey) = cJ(cKey) & ", " & feld(i, 10)
    If feld(i, 11) <> "" Then cK(cKey) = cK(cKey) & ", " & feld(i, 11)
    If feld(i, 12) <> "" Then cL(cKey) = cL(cKey) & ", " & feld(i, 12)
  Next i

  ReDim arr1(cEF.Count, 11)
  For Each cKey In cEF
    arr1(j, 0) = Split(cKey, "#")(0)
    arr1(j, 1) = Split(cKey, "#")(1)
    arr1(j, 2) = Split(cKey, "#")(2)
    arr1(j, 3) = Split(cKey, "#")(3)
    arr1(j, 4) = Replace(Replace(Trim(Replace(cEF(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 5) = cG(cKey)
    arr1(j, 6) = Split(cKey, "#")(4)
    arr1(j, 7) = Split(cKey, "#")(5)
    arr1(j, 8) = Replace(Replace(Trim(Replace(cJ(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 9) = Replace(Replace(Trim(Replace(cK(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 10) = Replace(Replace(Trim(Replace(cL(cKey), ",", " ")), " ", ","), ",,", ", ")
    arr1(j, 11) = Split(cKey, "#")(6)
    j = j + 1
  Next

  'Ergebnisse werden in Tabelle2 geschrieben
  With Sheets("Tabelle2")
    lngZz = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    .Range("A2:L" & lngZz).ClearContents
    .Cells(2, 1).Resize(j, 12).Value = arr1
  End With

End Sub