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,
03.03.2020, 00:10 (Dieser Beitrag wurde zuletzt bearbeitet: 03.03.2020, 00:10 von 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
'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.
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:
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
'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
