Beispiel:
https://www.herber.de/bbs/user/101381.xlsx
Ich möchte mir Pro user in einer Zelle alle ihm zugewiesene software anzeigen lassen.
Ich verzweifle hier :-)
Rückmeldung wäre nett !!!
>>> mfg Bernd <<<
Sub mach()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Long, letzteZeile As Long
Set WS1 = Worksheets("Tabelle1")
Set WS2 = Worksheets("tabelle2")
WS2.Rows("1:65536").EntireRow.Delete
WS2.Range("A1:B1").Value = WS1.Range("A2:B2").Value
For iZeile = 3 To WS1.Range("A65536").End(xlUp).Row
If WorksheetFunction.CountIf(WS2.Columns(1), WS1.Cells(iZeile, 1)) = 0 Then
letzteZeile = WS2.Range("A65536").End(xlUp).Row + 1
WS2.Cells(letzteZeile, 1) = WS1.Cells(iZeile, 1)
WS2.Cells(letzteZeile, 2) = WS1.Cells(iZeile, 2)
Else
letzteZeile = Application.Match(WS1.Cells(iZeile, 1), WS2.Columns(1), 0)
WS2.Cells(letzteZeile, 2) = WS2.Cells(letzteZeile, 2) & ", " & WS1.Cells(iZeile, 2)
End If
Next iZeile
End Sub
Sub software()
Dim rngC As Range, oSW As Object
Set oSW = CreateObject("scripting.dictionary")
With Sheets("tabelle1")
For Each rngC In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
If oSW.exists(rngC.Value) Then
oSW(rngC.Value) = oSW(rngC.Value) & vbLf & rngC.Offset(, 1).Value
Else
oSW(rngC.Value) = rngC.Offset(, 1).Value
End If
Next rngC
End With
With Worksheets.Add
.Cells(1, 1).Resize(oSW.Count) = WorksheetFunction.Transpose(oSW.keys)
.Cells(1, 2).Resize(oSW.Count) = WorksheetFunction.Transpose(oSW.items)
End With
End Sub
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen