Du hast sicher nicht festgestellt, dass mein Code nicht alle Ergebnisse liefert, oder hast Du?
Die letzte Zeile habe ich unterschlagen.
Dann habe ich den Speicher unnötig stark beansprucht mit meiner Array Dimensionierung.
Unten zwei Codevarianten die die gleichen Ergebnisse liefern, sich allein bei der Umsetzung der Anpassung der Spaltenbreite unterscheiden.
Code:
Option Explicit
' Bedingtes Transponieren
Sub Bedingtes_Transponieren()
Dim i As Long, j As Long, k As Long
Dim zZ As Long
Dim lngZ As Long
Dim feld
Dim vntK
Dim arr()
Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
With Sheets("Übersicht")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
feld = .Range("A2:C" & lngZ)
For i = 1 To lngZ - 1
If IsNumeric(feld(i, 3)) Then
vntK = feld(i, 1)
' If InStr(c(vntK), feld(i, 3)) = 0 Then 'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
c(vntK) = feld(i, 2) & "#" & c(vntK)
' End If 'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
zZ = Application.Max(zZ, UBound(Split(c(vntK), "#")) + 1)
End If
Next
ReDim arr(c.Count - 1, zZ)
For Each vntK In c.keys
arr(k, 0) = vntK
For j = 0 To UBound(Split(c(vntK), "#"))
arr(k, j + 1) = Split(c(vntK), "#")(j)
Next j
k = k + 1
Next vntK
End With
With Sheets("Tabelle1") 'Name der Zieltabelle
.Cells.Clear
Application.ScreenUpdating = False
.Range(.Cells(1, 1), .Cells(zZ, c.Count)) = Application.Transpose(arr)
.Range("A1").Resize(, c.Count).EntireColumn.AutoFit 'Spaltenbreite auto anpassen
Application.ScreenUpdating = True
End With
End Sub
Sub Bedingtes_Transponieren2()
Dim i As Long, j As Long, k As Long
Dim zZ As Long
Dim lngZ As Long
Dim feld
Dim vntK
Dim arr()
Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
With Sheets("Übersicht")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
feld = .Range("A2:C" & lngZ)
For i = 1 To lngZ - 1
If feld(i, 3) <> "" And IsNumeric(feld(i, 3)) Then
vntK = feld(i, 1)
' If InStr(c(vntK), feld(i, 3)) = 0 Then 'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
c(vntK) = feld(i, 2) & "#" & c(vntK)
' End If 'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
zZ = Application.Max(zZ, UBound(Split(c(vntK), "#")) + 1)
End If
Next
ReDim arr(c.Count - 1, zZ)
For Each vntK In c.keys
For j = 0 To UBound(Split(c(vntK), "#"))
arr(k, j) = Split(c(vntK), "#")(j)
Next j
k = k + 1
Next vntK
End With
With Sheets("Tabelle1") 'Name der Zieltabelle
.Cells.Clear
Application.ScreenUpdating = False
.Range("A1").Offset(1, 0).Resize(zZ, c.Count) = Application.Transpose(arr)
.Range("A1").Resize(, c.Count).EntireColumn.AutoFit 'Spaltenbreite auto anpassen
.Columns(1).WrapText = True 'Zellen der ersten Zeile Zeilenumbruch
.Range("A1").Resize(, c.Count) = c.keys
End With
Application.ScreenUpdating = True
End Sub
