AW: vba aus mehreren Dateien Range zusammenfügen
30.09.2013 22:51:06
fcs
Hallo Dani,
hier ist , das ich kürzlich hier gepostet hab zum Import aus CSV-Daten angepasst an den Import aus Exceldateien.
Gruß
Franz
Sub Daten_Importieren()
Dim wksZiel As Worksheet, lngZeile_Z As Long, rngCopy As Range
Dim wkbQuelle As Workbook
Dim strPfad As String, strDatei As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu importierenden Dateien auswählen"
.InitialFileName = "C:\Daten" 'Startverzeichnis anpassen ! _
If .Show = -1 Then
strPfad = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
Set wksZiel = ActiveWorkbook.Worksheets(1) 'in dieses Blatt werden die Daten kopiert
strPfad = strPfad & Application.PathSeparator
'xls/xlsx/xlsm/xlsb-Dateien suchen
strDatei = Dir(strPfad & "*.xls*")
lngZeile_Z = 1 '1. Einfügezeile ggf. anpassen
Application.ScreenUpdating = False
Do Until strDatei = ""
'Quelldatei schreibgeschützt öfnen
Set wkbQuelle = Application.Workbooks.Open(Filename:=strPfad & strDatei, _
ReadOnly:=True)
'Daten kopieren
Set rngCopy = wkbQuelle.Worksheets(1).Range("A1:T6") 'Bereich anpasen!!!
rngCopy.Copy wksZiel.Cells(lngZeile_Z, 1)
Application.CutCopyMode = False
GoTo Weiter01 'ggf. zu Kommentar machen, wenn die Infos eingetragen werden sollen
'Spalten mit Infos anfügen, z.B. zum sortieren
With wksZiel
With .Range(.Cells(lngZeile_Z, rngCopy.Columns.Count + 1), _
.Cells(lngZeile_Z + rngCopy.Rows.Count - 1, rngCopy.Columns.Count + 1))
'Dateiname rechts neben den Daten einfügen
.Value = strDatei
'fortlaufende Nr. für die Zeilen in Spalte V einfügen
With .Offset(0, 1)
.FormulaR1C1 = "=ROW()- " & lngZeile_Z & " + 1"
.Calculate
.Value = .Value
End With
End With
End With
Weiter01:
'Nächste Einfügezeile
lngZeile_Z = lngZeile_Z + rngCopy.Rows.Count
Set rngCopy = Nothing
'Quelldatei wieder schliessen
wkbQuelle.Close savechanges:=False
Set wkbQuelle = Nothing
'Nächste Datei schen
strDatei = Dir
Loop
Application.ScreenUpdating = True
Beenden:
End Sub