Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1272to1276
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Hilfe bei Array und Transponieren gesucht

Hilfe bei Array und Transponieren gesucht
Mirko
Hallo liebes Forum,
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

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Hilfe bei Array und Transponieren gesucht
02.08.2012 19:17:29
Uduuh
Hallo,
versuch's mal so:
Public Sub UEBENAHME()
On Error GoTo Fehler
Dim Dic As Object
Dim arr, i As Long, j As Long, s As String
Dim arrAus(), arrKeys, arrItems
Set Dic = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Tabelle1")
arr = Intersect(.Range("D6").CurrentRegion, .Columns("D:I"))
End With
For i = LBound(arr) To UBound(arr)
For j = 2 To 6
s = Trim(arr(i, j))
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
Next
ReDim arrAus(1 To Dic.Count, 1 To 2)
arrKeys = Dic.keys
arrItems = Dic.items
For i = 1 To Dic.Count
arrAus(i, 1) = arrKeys(i - 1)
arrAus(i, 2) = arrItems(i - 1)
Next
With ThisWorkbook.Sheets("Tabelle2")
.Range("C8").Resize(Dic.Count, 2).Value = arrAus
End With
Dic.RemoveAll
Set Dic = Nothing
Exit Sub
Fehler:
MsgBox "Fehler in Sub ÜBERNAHME" & vbCrLf & "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description
End Sub

Gruß aus’m Pott
Udo

Anzeige
AW: Hilfe bei Array und Transponieren gesucht
02.08.2012 19:41:02
Mirko
Hallo Uduuh,
hab vielen lieben Dank !! es funktioniert genau wie es soll ....
Danke, Danke, Danke !
AW: Hilfe bei Array und Transponieren gesucht
02.08.2012 19:46:53
Mirko
Hallo nochmal,
kann man die Ausgabe noch sortieren ? Es wird ja nach der Zahl 1 bis 5 "zusammengefasst" ?
Sprich die Zahl 1 steht in zeile 1, die 2 in 2 usw. ? Das wäre noch fein, ansonsten nochmals Danke ! ;)
AW: Hilfe bei Array und Transponieren gesucht
02.08.2012 19:58:56
Uduuh
Hallo,
sicher kann man.
      With ThisWorkbook.Sheets("Tabelle2").Range("C8").Resize(Dic.Count, 2)
.Value = arrAus
.Sort key1:=.Cells(1), order1:=xlAscending, Header:=xlNo
End With
Gruß aus’m Pott
Udo

Anzeige
AW: Hilfe bei Array und Transponieren gesucht
02.08.2012 20:04:38
Mirko
Feine Sache ! herzlichen Dank !
LG
Mirko

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige