AW: Zusammenzug aus 4 Dateien
25.08.2006 15:41:07
Heide_Tr
hallo Pascal,
nachfolgender Code sammelt Dir von 4 Dateien (Namen aktualisiseren) für 4 Tabellenblätter die Daten zusammen, wenn A belegt ist.
Voraussetzung ist eine leere Datei mit 4 Tabellenblättern. In dieses kopierst Du den Code und läßt ihn laufen.
Letzendlich besteht das Prinzip darin, dass die Bereiche der Tabellenblätter in Arrays gelesen und (wenn an Stelle 1 belegt) in ein Ergebnisarray (je Tabellenblatt) geschrieben werden. Am Ende werden die Daten rausgeschrieben.
Der Code "Exit Sub" muss in eine Zeile, der Editor hier zerpflückt sie mir.
Irgendwie ist die Lösung ziemlich doof, weil die ewigen Wiederholungen ganz sicher über Schleifen zusammengefasst werden könnten, aber es ist Freitag und es will mir so recht nicht gelingen ...
viele Grüße. Heide
Sub zusammen()
Dim arr1, arr2, arr3, arr4 As Variant
Dim erg1(164, 28), erg2(164, 28), erg3(164, 28), erg4(164, 28) As Variant
Dim ergz1, ergz2, ergz3, ergz4, i, j As Integer
ergz1 = 1
ergz2 = 1
ergz3 = 1
ergz4 = 1
For Each x In Array("a.xls", "b.xls", "c.xls", "d.xls") 'hier die Namen der 4 Dateien
If ActiveWorkbook.Name = x Then ' sicher ist sicher....
MsgBox "Aktives Workbook ist eines derjenigen, die ausgewertet werden sollen!!"
Exit
Sub
End If
arr1 = Workbooks(x).Worksheets(1).Range("A10:AB50")
arr2 = Workbooks(x).Worksheets(2).Range("A10:AB50")
arr3 = Workbooks(x).Worksheets(3).Range("A10:AB50")
arr4 = Workbooks(x).Worksheets(4).Range("A10:AB50")
For i = 1 To 41
If Len(arr1(i, 1)) > 0 Then
For j = 1 To 28 ' A-AB
erg1(ergz1, j) = arr1(i, j)
Next j
ergz1 = ergz1 + 1
End If
Next i
For i = 1 To 41
If Len(arr2(i, 1)) > 0 Then
For j = 1 To 28
erg2(ergz2, j) = arr2(i, j)
Next j
ergz2 = ergz2 + 1
End If
Next i
For i = 1 To 41
If Len(arr3(i, 1)) > 0 Then
For j = 1 To 28
erg3(ergz3, j) = arr3(i, j)
Next j
ergz3 = ergz3 + 1
End If
Next i
For i = 1 To 41
If Len(arr4(i, 1)) > 0 Then
For j = 1 To 28
erg4(ergz4, j) = arr4(i, j)
Next j
ergz4 = ergz4 + 1
End If
Next i
Next x
'alle ausgeben
Application.ScreenUpdating = False
For i = 1 To 4 ' für den wiederholten Lauf
Worksheets(i).Range("A1:AB160").ClearContents
Next i
For i = 1 To ergz1 - 1
For j = 1 To 28
Worksheets(1).Cells(i, j) = erg1(i, j)
Next j
Next i
For i = 1 To ergz2 - 1
For j = 1 To 28
Worksheets(2).Cells(i, j) = erg2(i, j)
Next j
Next i
For i = 1 To ergz3 - 1
For j = 1 To 28
Worksheets(3).Cells(i, j) = erg3(i, j)
Next j
Next i
For i = 1 To ergz4 - 1
For j = 1 To 28
Worksheets(4).Cells(i, j) = erg4(i, j)
Next j
Next i
Application.ScreenUpdating = True
End Sub