AW: viele Tabellen "verzahnen"
14.12.2006 13:23:00
Erich
Hi Daniel,
inspiriert durch deine gute Idee, die Zahl der Quellen variabel zu machen, hab ich meine Routine auch mal aufgebohrt:
Sub VerzahnenViele()
Dim wsQ() As Worksheet, wsZ As Worksheet, Eing As Variant
Dim lngQ() As Long, intQ() As Integer, lngM As Long, intM As Integer
Dim lngZ As Long, arrT, arrQ, arrZ, ii As Integer, zz As Long, ss As Integer
Const anzQ = 5 ' Hier Anzahl Quellblätter festlegen
ReDim wsQ(1 To anzQ)
Set wsQ(1) = Workbooks("MapA.xls").Worksheets(1) ' Hier Quellblätter bestimmen
Set wsQ(2) = Workbooks("MapB.xls").Worksheets(1) '
Set wsQ(3) = Workbooks("MapC.xls").Worksheets(1) '
Set wsQ(4) = Workbooks("MapD.xls").Worksheets(1) '
Set wsQ(5) = Workbooks("MapE.xls").Worksheets(1) '
' Set wsQ(6) = Workbooks(" .xls").Worksheets(1) '
Set wsZ = Workbooks("MapZ.xls").Worksheets(1) ' Hier Zielblatt bestimmen
' -------------------------------------------------------------- Quellgrößen ermitteln
ReDim lngQ(1 To anzQ), intQ(1 To anzQ)
For ii = 1 To anzQ
intQ(ii) = wsQ(ii).Cells(1, Columns.Count).End(xlToLeft).Column
intM = IIf(intQ(ii) < intM, intM, intQ(ii))
lngQ(ii) = wsQ(ii).Cells(Rows.Count, 1).End(xlUp).Row
lngM = IIf(lngQ(ii) < lngM, lngM, lngQ(ii))
lngZ = lngZ + lngQ(ii) - 1
Next ii
' --------------------------------------------------------------- Quelldaten einsammeln
ReDim arrQ(1 To lngM, 1 To intM, 1 To anzQ)
For ii = 1 To anzQ
arrT = Range(wsQ(ii).Cells(1, 1), wsQ(ii).Cells(lngQ(ii), intQ(ii))).Value
For ss = 1 To intQ(ii)
If ii = 1 Then arrQ(1, ss, 1) = arrT(1, ss)
For zz = 2 To lngQ(ii): arrQ(zz, ss, ii) = arrT(zz, ss): Next zz
Next ss
Next ii
Erase arrT ' aufräumen
' --------------------------------------------------------------- Zielblatt füllen
ReDim arrZ(1 To lngZ + 1, 1 To intM)
For ss = 1 To intM
lngZ = 1: arrZ(1, ss) = arrQ(1, ss, 1)
For zz = 2 To lngM
For ii = 1 To anzQ
If zz <= lngQ(ii) And ss <= intQ(ii) Then _
lngZ = lngZ + 1: arrZ(lngZ, ss) = arrQ(zz, ss, ii)
Next ii
Next zz
Next ss
wsZ.Cells.Clear
Range(wsZ.Cells(1, 1), wsZ.Cells(lngZ, intM)) = arrZ
Erase lngQ, intQ, arrQ, arrZ ' aufräumen
' --------------------------------------------------------------- Spezialeintrag Spalte H
' Eing = 789 ' nur für Test
Eing = False
While Eing = False
Eing = Application.InputBox("Bitte eine Zahl <> 0 eingeben", "Messwerte...", 1, , , , , 1)
Wend
wsZ.Columns(8).Insert
wsZ.Cells(1, 8) = "SmplInjVol"
Range(wsZ.Cells(2, 8), wsZ.Cells(lngZ, 8)) = CDbl(Eing)
End Sub
Grüße von Erich aus Kamp-Lintfort