Clever-Excel-Forum

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

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. Blush

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.

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

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

aLtheHeinz

atilla

aLtheHeinz

atilla