Wenn wert dann zusammenführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub a() Const SEP$ = "," Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tab01") Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tab02") Dim tQ As ListObject: Set tQ = WsQ.ListObjects(1) Dim tZ As ListObject: Set tZ = WsZ.ListObjects(1) Dim c As Range, d As Range, t$ With tZ.DataBodyRange For Each c In .Resize(.Rows.Count, 1) With tQ.DataBodyRange For Each d In .Offset(, 1).Resize(.Rows.Count, 1) If d = c Then t = t & d.Offset(, -1) & SEP Next d End With c.Offset(, 1) = t: t = vbNullString Next c End With Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing Set tQ = Nothing: Set tZ = Nothing: Set c = Nothing Set d = Nothing End Sub

Sub a() Const SEP$ = "," Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tab01") Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tab02") Dim tQ As ListObject: Set tQ = WsQ.ListObjects(1) Dim tZ As ListObject: Set tZ = WsZ.ListObjects(1) Dim a, b, c(), t$, i&, j& Application.ScreenUpdating = False With tZ.DataBodyRange a = .Resize(.Rows.Count, 1) ReDim c(1 To UBound(a), 1 To UBound(a)) End With With tQ.DataBodyRange b = .Resize(.Rows.Count, 2) End With For i = LBound(a) To UBound(a) For j = LBound(b) To UBound(b) If a(i, 1) = b(j, 2) Then t = t & b(j, 1) & SEP Next j c(i, 1) = a(i, 1): c(i, 2) = t: t = vbNullString Next i With tZ.DataBodyRange .Resize(.Rows.Count, 2) = c End With Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing Set tQ = Nothing: Set tZ = Nothing Erase a: Erase b: Erase c End Sub

Wenn du einen Wert in eine Zelle schreibst, muss Excel eine Vielzahl von Aufgaben erledigen (z.B. Bildschirm aktualisiern; Überprüfen, ob in einer geöffneten Datei Formeln enthalten sind, die auf diese Zelle referenzieren und diese neu berechnen usw)
Wenn du die Zellen einzeln in einer Schleife befüllt, läuft dieses Programm für jede Zelle wiederholt ab.
Wenn du die Werte jedoch erst ein einem Array sammelst und dann das Array als ganzes in die Zellen schreibst, dann kann Excel diese Aufgaben en Block für alle Zellen in einem Schritt ausführen.
Im Prinzip so, wie wenn du bei deinem Handwerker für dein Haus 10x je 1 neues Fenster bestellst und der Handwerker dann 10x anfahren muss und 10 Rechnungen erstellt, die du dann 10x überweisen musst
Bestellst du jedoch 1x 10 Fenster im Block, dann fährt er nur einmal an und schreibt dir auch nur eine Rechnung.
Gruß Daniel

Moin Hajo,
vielen Dank für die Erklärung.
Ich hoffe Du kannst mir noch bei einer Frage helfen.
Michael hat hier ein Makro geschrieben, das schon fast alles macht was ich brauche. Ich versuche mich jetzt schon eine Weile daran, habe auch eine Lösung, bin aber auch sicher, dass es besser geht.
Frage:
Aus dem Array sollen die Daten der Spalte 2 in die 3. Spalte des loTarget kopiert werden.
Meine Lösung ist pragmatisch und gefällt mir nicht, da ich hier keinen flexiblen Zielbereich habe.
wsTarget.Range("c2:c8") = ExtractFromArray(arrQuelle:=c, arrColumns:=Array(2))
Wie immer bin ich für den Tip, wie es richtig geht sehr dankbar.
Hier nochmal das ganze Makro:

Sub Refresh_list()
Const SEP$ = ","
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim wsSource As Worksheet: Set wsSource = Wb.Worksheets("Tab01")
Dim wsTarget As Worksheet: Set wsTarget = Wb.Worksheets("Tab02")
Dim loSource As ListObject: Set loSource = wsSource.ListObjects(1)
Dim loTarget As ListObject: Set loTarget = wsTarget.ListObjects(1)
'Dim c As
Dim a, b, t$, i&, j&
Dim c()
Dim rgTarget As Range: Set retarget = Tabelle2.Range("C2")
Dim strColumnName As String
Dim lcSourceTmp As ListColumn
strColumnName = "Keyword"
Application.ScreenUpdating = False
With loTarget.DataBodyRange
a = .Resize(.Rows.Count, 1)
ReDim c(1 To UBound(a), 1 To UBound(a))
End With
With loSource.DataBodyRange
b = .Resize(.Rows.Count, 2)
End With
For i = LBound(a) To UBound(a)
For j = LBound(b) To UBound(b)
If a(i, 1) = b(j, 2) Then t = t & b(j, 1) & SEP
Next j
c(i, 1) = a(i, 1): c(i, 2) = t: t = vbNullString
Next i
'    Copy Data to target
wsTarget.Range("c2:c8") = ExtractFromArray(arrQuelle:=c, arrColumns:=Array(2))
'    With loTarget.DataBodyRange
'        .Resize(.Rows.Count, 3) = c
'    End With
Set Wb = Nothing: Set wsSource = Nothing: Set wsTarget = Nothing
Set loSource = Nothing: Set loTarget = Nothing
Erase a: Erase b: Erase c
End Sub

Lg Felix

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

333 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Wenn wert dann zusammenführen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

333 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread