Werte aus Zellen zusammenfassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Florian,
ohne deine txt-Mappe anzusehen ein VBA-Lösung:

Option Explicit
'    angenommen:
'    Alle Orte stehen im Tabellenblatt "Datenbank" in Spalte A, in Spalte B die Ortsnamen dazu
'    Im Tabellenblatt "Tabelle2" steht in der Zelle B2 die gesuchte Postleitzahl
'    dann werden die zur Postleitzahl gehörenden Orsnamen Semikolon getrannt in Zelle B3  _
ausgegeben
Public Sub Orte_in_Zelle()
Dim WkSh_Q   As Worksheet
Dim WkSh_Z   As Worksheet
Dim rZelle   As Range
Dim sFundst  As String
Set WkSh_Q = ThisWorkbook.Worksheets("Datenbank")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle2")
If Trim$(WkSh_Z.Range("B2").Value)  "" And IsNumeric(WkSh_Z.Range("B2").Value) Then
WkSh_Z.Range("B3").ClearContents
Else
MsgBox "Sie müssen eine 5-stellige Postleitzahl in die Zelle ""B2"" eingeben - danke.",  _
_
48, "   Hinweis für " & Application.UserName
Exit Sub
End If
With WkSh_Q.Columns(1)
Set rZelle = .Find(What:=WkSh_Z.Range("B2").Value, LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
If WkSh_Z.Range("B3").Value = "" Then
WkSh_Z.Range("B3").Value = WkSh_Q.Range("B" & rZelle.Row).Value
Else
WkSh_Z.Range("B3").Value = WkSh_Z.Range("B3").Value & "; " & WkSh_Q.Range("B" &  _
rZelle.Row).Value
End If
Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address  sFundst
End If
End With
End Sub

Gruß Peter

Sub Makro3() Dim zellC As Range Dim zellA As Range Dim NameComi As String Worksheets("Tabelle1").Range(Range("A1"), Range("A1").End(xlDown)).AdvancedFilter Action:= _ xlFilterCopy, CopyToRange:=Columns("C:C"), Unique:=True For Each zellC In Range("C2:C" & Worksheets("Tabelle1").Cells(1048576, "C").End(xlUp).Row) For Each zellA In Sheets("Tabelle1").Range(Range("A2"), Range("A2").End(xlDown)) If Not NameComi = "" Then If zellC.Value = zellA.Value Then NameComi = NameComi & ";" & zellA.Offset(0, 1).Value Else If zellC.Value = zellA.Value Then NameComi = zellA.Offset(0, 1).Value End If Next zellC.Offset(0, 1) = NameComi NameComi = "" Next End Sub

Sub MitDic() Dim arr Dim z As Long Dim dic arr = Range(Cells(1, 1), Cells(1, 2).End(xlDown)).Value Set dic = CreateObject("Scripting.Dictionary") For z = 1 To UBound(arr) If dic.exists(arr(z, 1)) Then dic(arr(z, 1)) = dic(arr(z, 1)) & "," & arr(z, 2) Else dic(arr(z, 1)) = arr(z, 2) End If Next With Cells(1, 3).Resize(dic.Count, 2) .Columns(1) = WorksheetFunction.Transpose(dic.keys) .Columns(2) = WorksheetFunction.Transpose(dic.Items) End With End Sub

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte aus Zellen zusammenfassen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread