AW: VBA - Wert in neue Excel schreiben
11.09.2017 12:01:32
Michael
Alex,
...folgende Datei: https://www.herber.de/bbs/user/116151.xlsm
In der Mappe habe ich den Teil, der beim Öffnen der Mappe aktiv wird, noch auskommentiert - das Makro im allgemeinen Modul1 kannst Du dann dennoch manuell auslösen um zu testen; wenn alles nach Wunsch läuft, bitte das Ereignis-Makro "WorkbookOpen" aktiv setzen.
Diese Mappe kannst Du umbenennen, ist unerheblich, allerdings gehe ich gem. Deiner Angaben davon aus, dass diese Mappe NICHT im gleichen Verzeichnis liegt, wo die Import-Dateien liegen.
Die Daten werden ins Blatt "Import" fortlaufend übernommen, im Blatt "Dateiliste" werden die Dateinamen der importierten Dateien gesammelt.
Nach Makroduchlauf per Ereignis "WorkbookOpen" wirst Du informiert, aus wievielen Dateien Daten importiert wurden (nicht beim manuellen Auslösen).
Im Funktionsmakro "ImportAusVerzeichis" kannst Du zentral definieren, ab wo der zu kopierende Zellbereich beginnt (aktuell "A2") und bis zu welcher Spalte (aktuell "AN") - das Zeilenende wird jeweils mit der letzten befüllten Zelle aus Spalte "A" berechnet.
Übernommen werden die Zellwerte und Zahlenformate - falls Du da auch andere Formatierungen übernehmen willst, müsste man das ändern.
Die Datei wird aktuell NICHT automatisch gespeichert nach den Importvorgängen; das könnte noch geändert werden, falls erforderlich (und ggf. auch autom. geschlossen werden).
Hier noch die Codes:
Code für das Arbeitsmappen-Modul (DieseArbeitsmappe):
Private Sub Workbook_Open()
ImportCounter = 0
Call ImportAusVerzeichnis
MsgBox "Datei-Import abgeschlossen. Es wurden Daten aus " & _
ImportCounter & " Dateien übernommen.", vbInformation, "AutoImport"
End Sub
Code für ein allgemeines Modul (zB Modul1):
Public ImportCounter As Long
Sub ImportAusVerzeichnis()
Const HAUPTPFAD$ = "C:\abc\def\ghi" 'anpassen, wo liegen die Import-Dateien
Const STARTZELLE = "A2" 'anpassen, wo beginnt der Import-Bereich
Const LETZTESPALTE = "AN" 'anpassen, in welche Spalte reicht der Import-Bereich
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Import")
Dim WsI As Worksheet: Set WsI = WbZ.Worksheets("Dateiliste")
Dim WbQ As Workbook, WsQ As Worksheet
Dim Pfad$, ImportDateien As Object, Datei$, D As Range, Z&
Application.ScreenUpdating = False
Set ImportDateien = CreateObject("Scripting.Dictionary")
With WsI
If .Cells(.Rows.Count, "A").End(xlUp).Row > 2 Then
For Each D In .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
ImportDateien.Add D, ""
Next D
End If
End With
Pfad = IIf(Right(HAUPTPFAD, 1) = "\", HAUPTPFAD, HAUPTPFAD & "\")
Datei = Dir(Pfad & "*.xls*", vbDirectory)
Do Until Datei = ""
If Not ImportDateien.exists(Datei) Then
ImportCounter = ImportCounter + 1
WsI.Cells(WsI.Rows.Count, "A").End(xlUp).Offset(1, 0) = Datei
Set WbQ = Workbooks.Open(Pfad & Datei)
With WbQ
Set WsQ = .Worksheets(1)
With WsQ
Z = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(STARTZELLE & ":" & LETZTESPALTE & Z).Copy
End With
WsZ.Cells(WsZ.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial _
xlPasteValuesAndNumberFormats
.Close False
End With
Set WsQ = Nothing: Set WbQ = Nothing
End If
Datei = Dir
Loop
Set WbZ = Nothing: Set WsZ = Nothing: Set WsI = Nothing
ImportDateien.RemoveAll: Set ImportDateien = Nothing
Set D = Nothing
End Sub
Gib Bescheid!
LG
Michael
