AW: Makro, dass Daten aus Excel in eine Datei über
26.08.2015 10:59:49
Matthias
Hallo Braun,
bitte etwas Geduld mitbringen, wir sind keine Angestellten hier ;)
Standard-Verzeichnis bitte anpassen.
Option Explicit
' öffentliche Variablen
Dim myFileAddress As Variant, myFileDirectory As String, myFile As String
Dim wksZiel As Worksheet
Dim wbZiel As Workbook
Sub Dateiimport()
Dim Zähler As Long
' -- Bezüge --
Const StandardVerzeichnis = "R:\Arbeitsordner\04 AGW\2015-08-11 Lagerdurchmesser OP60"
Set wksZiel = Tabelle1
Set wbZiel = ThisWorkbook
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Hinweis
MsgBox "Dieses Tool lädt sämtliche Excel-Tabellen im ausgwählten Ordner in das Dokument. " & _
"Dateien die nicht erfasst werden sollen, sind vorher in ein anderes Verzeichnis " & _
"zu verschieben. Der Vorgang kann je nach Anzahl mitunter einige Minuten in " & _
"Anspruch nehmen.", , "Hinweis"
' Standard-Verzeichnis wechseln
ChDrive Left(StandardVerzeichnis, 1)
ChDir StandardVerzeichnis
myFileAddress = Application.GetOpenFilename("Excel-Dateien *.xls*,*.xls*")
If myFileAddress = False Then GoTo Endmarke ' Wenn 'Abbrechen' gewählt, ...
myFileDirectory = CurDir(myFileAddress)
myFile = Dir("*.xls*")
Do Until myFile = ""
Open_File ' Datei öffnen und Inhalt kopieren
Zähler = Zähler + 1
Application.StatusBar = "Datei #" & Zähler & " """ & myFile & """ importiert"
myFile = Dir ' nächste Datei
Loop
' Kopf-/Fußzeilen löschen, Formatierung
Application.StatusBar = "Bereit"
MsgBox Zähler & " Dateien importiert.", vbInformation, "Vorgang abgeschlossen"
Endmarke: ' Grundeinstellungen
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub Open_File()
Dim wbQuelle As Workbook
Dim wks As Worksheet
' Quelldatei öffnen, nur Lesezugriff
Set wbQuelle = Workbooks.Open(Filename:=myFileDirectory & "\" & myFile, ReadOnly:=True)
' Inhalt jedes TB kopieren und in Zieldatei einfügen
For Each wks In wbQuelle.Worksheets
wks.Select
wks.Range("A1:" & wks.Range("A1").SpecialCells(xlCellTypeLastCell).Address).Copy
wbZiel.Activate
With wksZiel
If .Range("A1") "" Then
.Range("A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Select
Else: .Range("A1").Select
End If
.Paste
End With
wbQuelle.Activate
Next wks
' Quelldatei schließen
wbQuelle.Close savechanges:=False
wbZiel.Activate
wksZiel.Range("A1").Select
End Sub
lg Matthias