Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Hilfe bei Array und Transponieren gesucht | Herbers Excel-Forum


Betrifft: Hilfe bei Array und Transponieren gesucht von: Mirko
Geschrieben am: 02.08.2012 18:33:41

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

  

Betrifft: AW: Hilfe bei Array und Transponieren gesucht von: Uduuh
Geschrieben am: 02.08.2012 19:17:29

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



  

Betrifft: AW: Hilfe bei Array und Transponieren gesucht von: Mirko
Geschrieben am: 02.08.2012 19:41:02

Hallo Uduuh,

hab vielen lieben Dank !! es funktioniert genau wie es soll ....

Danke, Danke, Danke !


  

Betrifft: AW: Hilfe bei Array und Transponieren gesucht von: Mirko
Geschrieben am: 02.08.2012 19:46:53

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 ! ;)


  

Betrifft: AW: Hilfe bei Array und Transponieren gesucht von: Uduuh
Geschrieben am: 02.08.2012 19:58:56

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



  

Betrifft: AW: Hilfe bei Array und Transponieren gesucht von: Mirko
Geschrieben am: 02.08.2012 20:04:38

Feine Sache ! herzlichen Dank !

LG
Mirko