AW: Rows in Array einlesen (Dup.check) und Transp
06.10.2007 22:42:44
fcs
Hallo Robert,
mein Lösungsoeschlag
Gruß
Franz
Sub ArrayFuellen()
'Daten aus Bereich einlesen und dabei Zeilen ausfiltern und anschließend Ergebnis _
transponiert ausgeben
Dim Bereich As Range, arrData(), arrRows As Integer, arrCols As Integer
Dim wks As Worksheet
Dim wks_A As Worksheet, A_zeile As Integer, A_spalte As Integer
Dim Zeile%, Spalte%
Set wks = Worksheets(1) 'Blatt mit Eingabedaten
Set wks_A = Worksheets(2) 'Blatt für Datenausgabe
A_zeile = 2 '1. Ausgabe Zeile
A_spalte = 1 '1. AusgabeSpalte
With wks
'bereich mit daten
Set Bereich = .Range(.Cells(6, 2), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 9))
arrRows = Bereich.Columns.Count
arrCols = 0
'Daten einlesen
For Zeile = 1 To Bereich.Rows.Count
'Bedingungen; nur Zeilen, die bedingung erfüllen werden in Array eingelesen
If InStr(1, Bereich(Zeile, 1), "2") = 0 Then
arrCols = arrCols + 1
If arrCols > wks_A.Columns.Count - A_spalte + 1 Then
MsgBox "Zuviele Spalten für die Ausgabe erforderlich!"
Exit Sub
End If
ReDim Preserve arrData(1 To arrRows, 1 To arrCols)
For Spalte = 1 To Bereich.Columns.Count
arrData(Spalte, arrCols) = Bereich(Zeile, Spalte)
Next
End If
Next
'Daten transponiert ausgeben
For Zeile = LBound(arrData, 2) To UBound(arrData, 2)
For Spalte = LBound(arrData, 1) To UBound(arrData, 1)
wks_A.Cells(A_zeile + Spalte - 1, A_spalte) = arrData(Spalte, Zeile)
Next
A_spalte = A_spalte + 1
Next
End With
End Sub