|
Option Explicit
Sub Test()
Dim arrToUse() As Variant
arrToUse = MakeArray()
'TestIt
MsgBox UBound(arrToUse, 1) & vbNewLine & UBound(arrToUse, 2)
End Sub
Private Function MakeArray() As Variant
Dim Ws1 As Worksheet, Wsh As Worksheet, Wtmp As Worksheet
Dim rngCnt As Range, c As Range, arrRng() As Variant
Dim rngCopy As Range, rngDest As Range
On Error GoTo fail:
Set Ws1 = Sheets(1)
With Ws1
With .Rows(2)
Set rngCnt = Range(.Cells(1), .Cells(Columns.Count).End(xlToLeft))
End With
.Copy after:=Sheets(Sheets.Count)
Set Wtmp = ActiveSheet
End With
For Each c In rngCnt
If c.Value = "x" Then
Set Wsh = Sheets(c.Column + 1)
Set rngCopy = Wsh.Range(determExtent(Wsh)(3))
Set rngDest = Wtmp.Cells(determExtent(Wtmp)(1) + 1, 1)
rngCopy.Copy rngDest
End If
Next c
On Error GoTo 0
fail:
Select Case Err.Number
Case 0
MakeArray = Wtmp.Range(determExtent(Wtmp)(3))
Case Else
Call MsgBox("ungültige Angaben oder leere Tabelle", vbExclamation, "Abbruch")
End Select
Application.DisplayAlerts = False
Wtmp.Delete
Application.DisplayAlerts = True
End Function
Private Function determExtent(Sh As Worksheet) As Variant
Dim arrE(1 To 3) As Variant
With Sh
If .AutoFilterMode Then .Cells.AutoFilter
arrE(1) = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row
arrE(2) = .Cells.Find("*", .Cells(1), -4123, 2, 2, 2, False).Column
arrE(3) = .Range(.Cells(1, 1), .Cells(arrE(1), arrE(2))).Address(0, 0)
determExtent = arrE
End With
End Function
|