Hilfe bei Array und Transponieren gesucht
Mirko
komme beim Transponieren nicht klar.
Ich habe in Spalte 1 mehrere Zeilen Text stehen. in Spalte 2 - 6 stehen die Zahl 1 - 5. Nun sollen alle Texte aufgelistet werden bei dem die 1, die 2, ... oder alle Zahlen zutreffend sin und dann in eine Spalte kopiert werden. folgenden Code hab ich schon, der aber bei einem langen Text zu einem Fehler führt. ( drum Frage zu Transpose) - ( wahrscheinlich gehts der Code viel besser ) :
Public Sub UEBENAHME()
On Error GoTo Fehler
Dim Dic As Object
Dim arr, i As Long, s As String
Set Dic = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Tabelle1")
arr = Intersect(.Range("D6").CurrentRegion, .Columns("D:I"))
End With
For i = LBound(arr, 2) To UBound(arr, 1)
s = Trim(arr(i, 2))
If s "" Then
If Dic.exists(s) Then
Dic(s) = Dic(s) & vbLf & Trim(arr(i, 1))
Else
Dic(s) = Trim(arr(i, 1))
End If
End If
Next
''__
For i = LBound(arr, 2) To UBound(arr, 1)
s = Trim(arr(i, 3))
If s "" Then
If Dic.exists(s) Then
Dic(s) = Dic(s) & vbLf & Trim(arr(i, 1))
Else
Dic(s) = Trim(arr(i, 1))
End If
End If
Next
''__
For i = LBound(arr, 2) To UBound(arr, 1)
s = Trim(arr(i, 4))
If s "" Then
If Dic.exists(s) Then
Dic(s) = Dic(s) & vbLf & Trim(arr(i, 1))
Else
Dic(s) = Trim(arr(i, 1))
End If
End If
Next
''__
For i = LBound(arr, 2) To UBound(arr, 1)
s = Trim(arr(i, 5))
If s "" Then
If Dic.exists(s) Then
Dic(s) = Dic(s) & vbLf & Trim(arr(i, 1))
Else
Dic(s) = Trim(arr(i, 1))
End If
End If
Next
''__
For i = LBound(arr, 2) To UBound(arr, 1)
s = Trim(arr(i, 6))
If s "" Then
If Dic.exists(s) Then
Dic(s) = Dic(s) & vbLf & Trim(arr(i, 1))
Else
Dic(s) = Trim(arr(i, 1))
End If
End If
Next
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Tabelle2")
.Range("C8").Resize(Dic.Count, 1).Value = WorksheetFunction.Transpose(Dic.Keys)
.Range("D8").Resize(Dic.Count, 1).Value = WorksheetFunction.Transpose(Dic.Items)
End With
Dic.RemoveAll
Set Dic = Nothing
Application.ScreenUpdating = True
Exit Sub
Fehler:
MsgBox "Fehler in Sub ÜBERNAHME" & vbCrLf & "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description
Application.ScreenUpdating = True
End Sub
Vielen Dank im Vorraus für Eure Hilfe