Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Verbund. Zellen - Zusammen - Löschen MAKRO gesucht

Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
Stef@n
Hallo Liebe Herber-Freunde,
ich habe eine sehr große Datei, in der in Spalte A an verschiedenen Stellen Zellen miteinander verbunden sind, und in Spalte B die Zellen NICHT miteinander verbunden sind.
Bislang gehe ich händisch durch die gesamte Datei - markiere die jeweiligen Zellen in Spalte B (egal wieviel es sind) und lasse dann ein Makro laufen, das die jeweils einzelnen Werte aus der Spalte B
in der "ersten" Zelle in B zusammenführt , und anschliessend die entstandenen Leerzeilen
(quasi ab der 2. Zeile) löscht.
Diesen Prozess möchte ich gern soweit automatisieren, dass ein Makro die Tabelle so lange durchläuft,
dass er alle verbundenen Zellen in Spalte A findet, B markiert und dann das Makro ausführt.
Das Ziel ist, pro einzelner ID in Spalte A (siehe Tabelle im Anhang) auch nur eine Zelle in Spalte B
existiert . Wenn mehrere Zellen in B vorhanden sind, soll der Inhalt in der 1. Zeile zusammengeführt werden.
Hier die Datei mit ein paar "Test-Daten" https://www.herber.de/bbs/user/73365.xls
Hat jemand einen Tip ?
Freu mich sehr darauf ! :)
Besten Gruß
Stef@n
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
02.02.2011 15:37:47
Rudi
Hallo,
Sub tttt()
Dim rngC As Range, arrTmp, rngDel As Range
Const sDelim As String = "|"
For Each rngC In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If rngC.MergeArea.Cells.Count > 1 Then
If rngC.Address = rngC.MergeArea.Cells(1).Address Then
arrTmp = rngC.MergeArea.Offset(, 1).Resize(rngC.MergeArea.Cells.Count)
rngC.Offset(, 1) = Join(WorksheetFunction.Transpose(arrTmp), sDelim)
If rngDel Is Nothing Then
Set rngDel = rngC.Cells(2).Resize(rngC.MergeArea.Cells.Count - 1)
Else
Set rngDel = Union(rngDel, rngC.Cells(2).Resize(rngC.MergeArea.Cells.Count - 1))
End If
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub

Gruß
Rudi
Anzeige
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
03.02.2011 09:04:25
Stef@n
Hallo Rudi
vielen besten Dank für den Code. Ehrlich gesagt: Ich blicke da nicht durch, was der Code "so macht"
Auf jeden Fall funktioniert er für meine "Testdaten" einwandfrei.
Wenn ich den Code bei meinen Original-Daten laufen lasse, kommt eine Fehlermeldung
Aufrufezeichen - Typen unverträglich
Kannst du nochmal weiterhelfen ?
Gruß
Stef@n
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
03.02.2011 09:31:04
Rudi
Hallo,
Kannst du nochmal weiterhelfen ?

Ich kenne deine Originaldaten ja nicht.
Deine Testdaten sollten mit denen in der Struktur und den Datentypen schon übereinstimmen.
Gruß
Rudi
Anzeige
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
03.02.2011 10:12:46
Stef@n
Hallo Rudi
hier mal die Rohdaten (reduziert, da die Originaldatei größer 16 MB),
bei denen der Code den Fehler auswirft.
https://www.herber.de/bbs/user/73380.xls
Gruß
Stef@n
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
03.02.2011 11:36:31
Rudi
Hallo,
alles klar. Join() kann keine Strings mit mehr als 255 Zeichen.
Sub tttt()
Dim rngC As Range, arrTmp, rngDel As Range, i As Integer, sTmp As String
Const sDelim As String = " | "
For Each rngC In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If rngC.MergeArea.Cells.Count > 1 Then
If rngC.Address = rngC.MergeArea.Cells(1).Address Then
sTmp = ""
arrTmp = rngC.MergeArea.Offset(, 1).Resize(rngC.MergeArea.Cells.Count)
For i = 1 To UBound(arrTmp) - 1
sTmp = sTmp & arrTmp(i, 1) & sDelim
Next
sTmp = sTmp & arrTmp(i, 1)
rngC.Offset(, 1) = sTmp
If rngDel Is Nothing Then
Set rngDel = rngC.Cells(2).Resize(rngC.MergeArea.Cells.Count - 1)
Else
Set rngDel = Union(rngDel, rngC.Cells(2).Resize(rngC.MergeArea.Cells.Count - 1))
End If
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub

Gruß
Rudi
Anzeige
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
03.02.2011 12:07:24
Stef@n
Hallo Rudi,
:) die Fehlermeldung kommt nicht mehr !
Habe jetzt die Originaldatei genommen und eines passiert:
bis ca. Zeile 4500 macht der Code, was er soll.
Ab dort bis zur Zeile 17000 löscht die "Verbindung" der Zellen in Spalte A
... aber mehr passiert nicht (Zusammenführen der Zellen in B und löschen der Leerzeilen)
Idee meinerseits:
Kann ich dir mal die Originaldatei (gezippt) per Mail zur Verfügung stellen - vertraul natürlich ;)
Würd mich freuen
Gruß
Stef@n
AW: Verbund. Zellen - Zusammen - Löschen MAKRO gesucht
03.02.2011 12:07:37
Stef@n
Hallo Rudi,
:) die Fehlermeldung kommt nicht mehr !
Habe jetzt die Originaldatei genommen und eines passiert:
bis ca. Zeile 4500 macht der Code, was er soll.
Ab dort bis zur Zeile 17000 löscht die "Verbindung" der Zellen in Spalte A
... aber mehr passiert nicht (Zusammenführen der Zellen in B und löschen der Leerzeilen)
Idee meinerseits:
Kann ich dir mal die Originaldatei (gezippt) per Mail zur Verfügung stellen - vertraul natürlich ;)
Würd mich freuen
Gruß
Stef@n
Anzeige
Datei per Mail
03.02.2011 12:44:34
Rudi
Hallo,
kannst du machen.
vorname.nachname bei arcor in de.
Gruß
Rudi
AW: Datei per Mail
03.02.2011 13:02:43
Stef@n
prima - Danke !
Kommt gleich von meinem Firmenaccount
Gruß
Stef@n
AW: Datei per Mail
03.02.2011 14:04:23
Rudi
Hallo,
da unten sind die Zellen in A nicht verbunden. Also erst mal die Zellen verbinden.
Sub aaaa()
Dim rngc As Range, arrTmp, rngDel As Range, i As Integer, sTmp As String
Const sDelim As String = " | "
Application.ScreenUpdating = False
prcMergeCells
For Each rngc In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If rngc.MergeArea.Cells.Count > 1 Then
If rngc.Address = rngc.MergeArea.Cells(1).Address Then
sTmp = ""
arrTmp = rngc.MergeArea.Offset(, 1).Resize(rngc.MergeArea.Cells.Count)
For i = 1 To UBound(arrTmp) - 1
If arrTmp(i, 1)  "" Then sTmp = sTmp & arrTmp(i, 1) & sDelim
Next
sTmp = sTmp & arrTmp(i, 1)
rngc.Offset(, 1) = sTmp
If rngDel Is Nothing Then
Set rngDel = rngc.Cells(2).Resize(rngc.MergeArea.Cells.Count - 1)
Else
Set rngDel = Union(rngDel, rngc.Cells(2).Resize(rngc.MergeArea.Cells.Count - 1))
End If
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
Private Sub prcMergeCells()
Dim rngc As Range
For Each rngc In Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp)).Offset(, -1)
If rngc.Offset(1) = "" Then rngc.Resize(2).Merge
Next
End Sub
Gruß
Rudi
Anzeige
PERFEKT !
03.02.2011 14:34:03
Stef@n
Hallo Rudi
ich bin mehr als sprachlos - positiv gemeint !!! :)))
Einfach : PERFEKT !
Danke Dir sehr für Deine Unterstützung
... und irgendwie merke ich:
muss mich wohl mehr in VBA "einarbeiten"
Dein Code spart mir unendlich viel Arbeit !
Wünsche Dir noch einen schönen Tag
Besten Gruß
Stef@n

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige