|
Hallo,
eventuell so ...
Sub Test1()
Dim arr1 As Variant
Dim i As Long
Dim j As Long
Dim k As Long
arr1 = Range("A1").CurrentRegion
ReDim arr2(1 To UBound(arr1, 2), 1 To 1) As Variant
j = 1
For i = LBound(arr1) To UBound(arr1)
If Left(arr1(i, 4), 1) = 3 Or Left(arr1(i, 4), 1) = 8 Or Left(arr1(i, ), 2) = "AB" Then
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To j)
For k = 1 To UBound(arr1, 2)
arr2(k, j) = arr1(i, k)
Next k
j = j + 1
End If
Next i
Erase arr1
ReDim arr1(1 To UBound(arr2, 2), 1 To UBound(arr2, 1))
For i = LBound(arr2, 2) To UBound(arr2, 2)
For j = LBound(arr2, 1) To UBound(arr2, 1)
arr1(i, j) = arr2(j, i)
Next j
Next i
'Range("A1").CurrentRegion.ClearContents
Range("X1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
End Sub
Gruß Sabina
|