AW: Aus mehreren Excel dateien 5 Zellen kopieren
03.01.2007 21:06:09
fcs
Hallo Chris,
ich hab den Code jetzt mal so geändert, dass beim Kopieren nur die Formate und Zellwerte kopiert werden. Außerdem hab ich einige überflüssige Zeilen gelöscht (Do .. Loop-Schleife und Zeilenzähler), die hier nicht benötigt werden.
Leider konnte ich den Code nicht testen, hoffe er funktioniert so.
Ob durch die Änderungen auch dein Problem Nr. 1 beseitigt wird weiss ich nicht. Eigentlich sollten diese Zellinhalte beim Kopieren keine Probleme bereiten. Problemfall evtl. verbundenene Zellen.
Gruss
Franz
Sub Telliste()
'Eine Liste aus mehreren erstellen
'By Nike 23.05.01
Dim arrFilenames As Variant
Dim wbkArr As Workbook
Dim wbkBasis As Workbook
Set wbkBasis = ActiveWorkbook
Dim lngBasisZeil As Long
Selection:
' Zu öffnende Dateien erfragen
arrFilenames = Application.GetOpenFilename( _
"Exceldateien (*.xls), *.xls, Alle Dateien (*.*), *.*", 1, _
"Exceldateien auswählen...", MultiSelect:=True) ' Ausgewählte Dateien des Öffnen-Dialoges in Feld ablegen
If VarType(arrFilenames) = vbBoolean Then
If MsgBox("Sie haben keine Dateien ausgewählt. Möchten sie das Makro beenden?", vbYesNo, "Frage") = vbNo Then
GoTo Selection
Else
Set wbkBasis = Nothing
Exit Sub
End If
End If
Application.ScreenUpdating = False
'Die vom Makro vorgenommenen Tätigkeiten
'bleiben zur Geschwidigkeitssteigerung unsichtbar
lngBasisZeil = 1
For i = 1 To UBound(arrFilenames) ' Durchläuft die Anzahl der Dateien
'Wenn Datei noch nicht geöffnet
If FileOpenYet(Dir$(arrFilenames(i))) = False Then
'dann öffnen
Workbooks.Open FileName:=arrFilenames(i)
Else
'oder aktivieren
Workbooks(Dir$(arrFilenames(i))).Activate
End If
Set wbkArr = ActiveWorkbook
'hier kommt dann der Code rein, der die ausgewählten Dateien
'betrifft. Die Ursprungsdatei ist über wbkBasis ansprechbar.
lngBasisZeil = lngBasisZeil + 1
With wbkBasis.Worksheets(1)
wbkArr.Worksheets(1).Range("E7").Copy
.Cells(lngBasisZeil, 5).PasteSpecial Paste:=xlPasteFormats
.Cells(lngBasisZeil, 5).PasteSpecial Paste:=xlPasteValues
wbkArr.Worksheets(1).Range("C9").Copy
.Cells(lngBasisZeil, 4).PasteSpecial Paste:=xlPasteFormats
.Cells(lngBasisZeil, 4).PasteSpecial Paste:=xlPasteValues
wbkArr.Worksheets(1).Range("B4").Copy
.Cells(lngBasisZeil, 3).PasteSpecial Paste:=xlPasteFormats
.Cells(lngBasisZeil, 3).PasteSpecial Paste:=xlPasteValues
wbkArr.Worksheets(1).Range("I16").Copy
.Cells(lngBasisZeil, 2).PasteSpecial Paste:=xlPasteFormats
.Cells(lngBasisZeil, 2).PasteSpecial Paste:=xlPasteValues
wbkArr.Worksheets(1).Range("E94").Copy
.Cells(lngBasisZeil, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(lngBasisZeil, 1).PasteSpecial Paste:=xlPasteValues
End With
wbkArr.Close savechanges:=False 'Datei schließen
Set wbkArr = Nothing
Next i
Set wbkArr = Nothing
'Ursprüngliche Datei wieder aktivieren
wbkBasis.Activate
Set wbkBasis = Nothing 'Die Variable zurücksetzen
'und den Monitor aktivieren
Application.ScreenUpdating = True
End Sub
Function FileOpenYet(FileName As String) As Boolean
'eine Funktion, die Prüft ob eine Datei schon geöffnet ist.
Dim s As String
On Error GoTo Nonexistent
s = Workbooks(FileName).Name
FileOpenYet = True
Exit Function
Nonexistent:
FileOpenYet = False
End Function