Zusammenführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim rng As Range, MyAddy$ Dim MyTxt$ For Each rng In Selection If rng.Value "" Then MyTxt$ = MyTxt$ & "/" & rng.Value MyAddy = rng.Address Next If Len(MyTxt) > 0 Then Range(MyAddy) = Right(MyTxt, Len(MyTxt) - 1)

Hi Matthias,
sry aber mein Freund und ich benutzen denselben Account,da wir gemeinsam immer an den gleichen Sachen arbeiten. Daher die unterschiedlichen Namen :-) Mit einem Stefan können wir aber leider noch nicht dienen :-)
So noch eine kleine Ergänzung:
Dim rng As Range, MyAddy$
Dim MyTxt$
Dim Bereich As Range
Set Bereich = Range("A1:ZZ5000")
For Each rng In Bereich
If rng.Value <> "" Then MyTxt$ = MyTxt$ & "/" & rng.Value
MyAddy = rng.Address
Next
If Len(MyTxt) > 0 Then Range(MyAddy) = Right(MyTxt, Len(MyTxt) - 1)
Ich habe "versucht" das Makro nun so anzupassen, dass es jede Zeile in der Range durchläuft aber
das will irgendwie nicht so klappen. Hast du noch einen letzten Tipp für mich?
Danke!
Gruß Daniel

Hi
prinzipell funktioniert dein Code schon.
er dauert halt bei der Zellenzahl ein kleines bisschen länger.
desweitern hast du das Problem, dass eine Excelcells maximal c.a. 32.000 Zeichen fassen kann. (dh wenn nur 1 Zeichen pro Zelle steht, dann kannst du in einer Zelle maximal die Werte von 3 Spalten darstellen).
dh du solltest erstmal tacheles reden und beschreiben, worum es tatsächlich geht und wie gross die Datenmengen wirklich sind (Anzahl belegte Zellen, wieviel Text steht in einer Zelle) und dir nochmal Gedanken darüber machen, wie das Ergebnis dargstellt werden soll unter der Prämisse, dass in eine Zelle maximal 32.000 Zeichen passen.
probiere mal diesen Code, dass ist etwas schneller und an deine Datenmenge angepasst:

Sub test()
Dim rng As Range, MyAddy As String
Dim MyTxt
Dim Bereich As Range
Dim arr, a
Dim i As Long
Set Bereich = Range("A1:ZZ5000")
arr = Bereich.Value
ReDim MyTxt(1 To 1, 1 To 1)
i = 1
For Each a In arr
If a  "" Then
If (1 + Len(a) + Len(MyTxt(1, i))) > 32767 Then
i = i + 1
ReDim Preserve MyTxt(1 To 1, 1 To i)
End If
MyTxt(1, i) = MyTxt(1, i) & "/" & a
End If
Next
ReDim arr(1 To UBound(MyTxt, 2), 1 To 1)
For i = 1 To UBound(MyTxt, 2)
arr(i, 1) = MyTxt(1, i)
Next
With Bereich
With .Cells(.Rows.Count, .Columns.Count)
.Offset(1, 0).Resize(UBound(arr, 1), 1).Value = arr
End With
End With
End Sub

Gruß Daniel
Gruß Daniel

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread