AW: Werte aus verschiedenen Dateien in 1 D. kopier
12.05.2008 21:38:00
fcs
Hallo vux,
ich hab auch mal in meinem Archiv gestöbert und eine Lösung etwas für dich angepasst.
Ablauf ist ähnlich wie bei Josef; allerdings werden die Zellen von der Quelle ins Ziel kopiert und nicht via Array übertragen.
Ich hab in Excel97 Probleme mit einigen Formaten (Datum, Währung) wenn ich nicht die Kopierfunktionen benutze. Dann geraten manchmal US-Formate in die Zellen.
Per Parameter kannst du einstellen, ob du nur die Werte oder Alles (Werte, Formate, Formeln) kopieren willst.
Gruß
Franz
'Erstellt: fcs 2006-08-15, modifiziert 2008-05-12
'Programm: Excel 97
Sub aatest()
Dim strVerzeichnis As String, wksSteuer As Worksheet, varListe As Variant
Dim lngZeile As Long, intI As Integer
' Set wksSteuer = ThisWorkbook.Worksheets("Steuerung")
strVerzeichnis = fncVerzeichnis(strFilter:="Exceldateien(*.xls), *.xls")
If strVerzeichnis "" Then
With ThisWorkbook.Worksheets("Database")
'Letzte Spalte in Zieltabelle
intI = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Import starten
If fncZusammenfuehren_Daten(varDateiListe:=varListe, _
strVerzeichnis:=strVerzeichnis, _
strFilter:="*.xls", _
varQuelleName:="Database", _
lngZeile1:=2, intSpalten:=intI, _
wksZiel:=ThisWorkbook.Worksheets("Database"), _
bolNurWerte:=True) = True Then
' With wksSteuer
'Liste der Quelldateien löschen
'.Range(.Cells(4, 1), .Cells(4, 1).End(xlDown)).ClearContents
'Liste der Quelldateien schreiben
'.Cells(2, 1).Value = strVerzeichnis
'lngZeile = 4
'For intI = LBound(varListe) To UBound(varListe)
' .Cells(lngZeile, 1).Value = varListe(intI)
' lngZeile = lngZeile + 1
'Next
' End With
Else
'do nothing
End If
End If
End Sub
Function fncZusammenfuehren_Daten(varDateiListe As Variant, strVerzeichnis As String, _
varQuelleName As Variant, lngZeile1 As Long, intSpalten As Integer, _
wksZiel As Worksheet, Optional strFilter As String = "*.xls", _
Optional bolNurWerte As Boolean = True) As Boolean
'Kopiert die Daten aus der Quelltabelle der Dateien im Verzeichnis in die Zieltabelle
'Erläuterung Parameter:
'varDateiListe = Array-Variable in der die Quell-Dateinamen gespeichert werden
'strVerzeichnis = Verzeichnis in dem die Quelldateien gesucht werdne sollen
'varQuelleName = Name oder Index-Nummer Quell-Tabellenblatts
'lngZeile1 = 1. Datenzeile
'intSpalten = Anzahl Spalten
'wksZiel = Zieltabellenblatt
'strFilter = Dateifilter für die Quelldateien
'bolNurWerte = True: nur Werte werden kopier, False: Alles wird kopiert
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim lngLetzteZeile As Long, lngZeileDaten As Long, lngNr As Long
Dim strDatei As String
Dim arrDateien() As String, intCount As Integer
Dim strMsg As String, intFehler As Integer
On Error GoTo Fehler
Application.ScreenUpdating = False
'Exceldateien im Verzeichnis Öffnen
strDatei = Dir(strVerzeichnis & Application.PathSeparator & strFilter)
Do Until strDatei = ""
lngNr = lngNr + 1
Application.StatusBar = "Die " & lngNr - 1 _
& ". Datei wird bearbeitet, Dateiname: " & strDatei
'Quelldatei schreibgeschützt öffnen
strDatei = strVerzeichnis & Application.PathSeparator & strDatei
Set wbQuelle = Workbooks.Open(FileName:=strDatei, ReadOnly:=True)
intFehler = 1
Set wksQuelle = wbQuelle.Worksheets(varQuelleName)
'Nächste Einfügezeile in Zieltabelle ermitteln
With wksZiel
lngZeileDaten = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With wksQuelle
If lngZeileDaten + .UsedRange.Rows.Count > wksZiel.Rows.Count Then
MsgBox "Nicht genug freie Zeilen zum Übernehmen der nächsten Daten!"
GoTo Beenden
End If
'Dateiname in Importliste eintragen
intCount = intCount + 1
ReDim Preserve arrDateien(1 To intCount)
arrDateien(intCount) = wbQuelle.Name
'Datenbereich ab intZeile1 kopieren
.Visible = xlSheetVisible
lngLetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile Spalte A
If bolNurWerte = True Then
.Range(.Cells(lngZeile1, 1), .Cells(lngLetzteZeile, intSpalten)).Copy
wksZiel.Cells(lngZeileDaten, 1).PasteSpecial Paste:=xlPasteValues
Else
.Range(.Cells(lngZeile1, 1), .Cells(lngLetzteZeile, intSpalten)).Copy _
Destination:=wksZiel.Cells(lngZeileDaten, 1)
End If
Application.CutCopyMode = False
End With
ResumeFehler1:
'Quelldatei ohne speichern schliessen
wbQuelle.Close Savechanges:=False
'nächste Datei suchen
strDatei = Dir
Loop
'Quelldateiliste zurückschreiben
varDateiListe = arrDateien
fncZusammenfuehren_Daten = True
GoTo Beenden
Fehler:
strMsg = "Fehler Nummer: " & Err.Number & vbLf & Err.Description
Select Case intFehler
Case 1
strMsg = strMsg & vbLf & vbLf & "Quelltabelle " & varQuelleName _
& " ist in der Datei " & wbQuelle.Name & " nicht vorhanden!"
MsgBox strMsg
intFehler = 0
Resume ResumeFehler1:
Case Else
MsgBox strMsg
End Select
fncZusammenfuehren_Daten = False
Beenden:
Set wbQuelle = Nothing: Set wksQuelle = Nothing
ReDim arrDateien(0)
Application.StatusBar = False
Application.ScreenUpdating = True
End Function
Function fncVerzeichnis(Optional strFilter As String = "Alle(*.*), *.*") As String
'Auswahl einer Datei zur Auswahl eines Verzeichnisses
Dim varAuswahl As Variant
varAuswahl = Application.GetOpenFilename(FileFilter:=strFilter, _
Title:="Bitte eine Datei im gewünschten Verzeichnis selektieren und 'Öffnen'")
If varAuswahl False Then
'Dateiname abtrennen
Do Until Right(varAuswahl, 1) = Application.PathSeparator
varAuswahl = Left(varAuswahl, Len(varAuswahl) - 1)
Loop
fncVerzeichnis = Left(varAuswahl, Len(varAuswahl) - 1)
End If
End Function