Mehrere Inhalte in einer Zelle kopieren

Hallo VBA Experten,
bisher habe ich immer professionelle Hilfe im Forum gefunden,
mit der ich Probleme im VBA gelöst habe.
Bei meinem aktuellen Problem finde ich leider keine Lösung und
hoffe auf eure Hilfe!
Ich möchte aus Datei 1 mit der If-Bedingung mehrere Zelleinhalte kopieren und
in EINER Zelle in der Datei 2 einfügen.
Kurze Darstellung zum Verständnis:
Spalte A hat 1 und
Spate B hat "Fester Text" dann
Inhalt C kopieren.
und das ganze sollte in der Schleife die restlichen Zelle mit der gleichen If Bedingung überprüfen und anschließend zusammengefasst
in der Datei 2 Spalte A Zeile 1 eingefügt werden.
Nun kommt die Herausforderung:
Die Suche bzw. If-Bedingung soll wiederholt nach
Spalte A = 2 und
Spalte B = "Fester Text" dann
Inhalt C kopieren
weiterlaufen.
Die Zahl in der Spalte A geht bis 90.
Besten Dank schon Mal für eure Antwort!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Test() Dim zz As Long Dim sAdr As String Dim i As Long Dim x As Long Application.ScreenUpdating = False 'Das "Flackern" ausstellen Workbooks.Open Filename:="C:\Users\weber\Desktop\Datei2.xlsx" Windows("Datei1.xlsm").Activate Sheets("Test").Select i = 0 Do Until i = 6 i = i + 1 For zz = 1 To 10 x = i If Cells(zz, 1) = x And _ Cells(zz, 2) = "Festwert" Then sAdr = sAdr & "; " & Cells(zz, 3) End If Next zz Windows("Datei2.xlsx").Activate Sheets("Tabelle1").Select Cells(1, i) = Mid(sAdr, 3) Loop End Sub

Sub Test() Dim zz As Long Dim sAdr As String Dim i As Long Application.ScreenUpdating = False 'Das "Flackern" ausstellen Workbooks.Open Filename:="C:\Users\weber\Desktop\Datei2.xlsx" Windows("Datei1.xlsm").Activate Sheets("Test").Select i = 0 Do Until i = 6 i = i + 1 For zz = 1 To 10 If Cells(zz, 1) = i And _ Cells(zz, 2) = "Festwert" Then sAdr = sAdr & "; " & Cells(zz, 3) End If Next zz Windows("Datei2.xlsx").Activate Sheets("Tabelle1").Select Cells(1, i) = Mid(sAdr, 3) Loop End Sub

Weber,
...kann so ausschauen:

Sub a()
Const TRENN As String = ";"
Dim WbQ As Workbook: Set WbQ = ThisWorkbook
Dim WsQ As Worksheet: Set WsQ = WbQ.Worksheets("Tabelle1")
Dim WbZ As Workbook, WsZ As Worksheet
Dim Daten As Range
Dim aD, aId, DicId As Object, j
Dim i As Long, k As Long, Sp As Long, t As String
Application.ScreenUpdating = False
With WsQ
Set Daten = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp))
aD = Daten
With Daten
aId = Application.Transpose(.Resize(.Rows.Count, 1))
End With
End With
Set DicId = CreateObject("Scripting.Dictionary")
For i = LBound(aId) To UBound(aId)
If Not DicId.exists(aId(i)) Then DicId.Add (aId(i)), 0
Next i
Set WbZ = Workbooks.Add
Set WsZ = WbZ.Worksheets(1)
For Each j In DicId.keys
For k = LBound(aD) To UBound(aD)
If aD(k, 1) = j Then t = t & aD(k, 3) & TRENN
Next k
t = Left(t, Len(t) - 1)
With WsZ
Sp = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
.Cells(1, Sp) = t
End With
t = vbNullString
Next j
With WsZ
.Columns.EntireColumn.AutoFit
.Columns(1).Delete
End With
Application.ScreenUpdating = False
End Sub

Ist auf Basis Deines letzten Bsp-Bildes und enthält schon ein paar Annahmen, um das ganze evtl. universeller zu gestalten. Beachte meinen ersten Hinweis: Es gibt ein Limit an Zeichen, den eine Zelle aufnehmen kann, das wird aktuell im Code noch nicht abgefangen; je nachdem wie lange Deine Ausgangsliste bzw. die Zelltexte sind, kann das evtl. Fehler werfen!
Gib Bescheid!
LG
Michael

Beliebteste Forumthreads (12 Monate)

Mehrere Inhalte in einer Zelle kopieren

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

373 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mehrere Inhalte in einer Zelle kopieren

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

373 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread