Ziel
Man möchte in die aktuell geöffnete Arbeitsmappe in eine bestimmte Tabelle Daten aus einer anderen, Arbeitsmappe aus einer definierten Tabelle kopieren.
Wir unterscheiden einfachheitshalber zwischen
- Zielarbeitsmappe: Die geöffnete Arbeitsmappe, in die die Daten kopiert werden sollen
- Quellarbeitsmappe: Die Arbeitsmappe, die die zu kopierenden Daten enthält.
Ausganssituation
Die Zielarbeitsmappe ist geöffnet und die Tabelle in welche die Quelldaten importiert werden sollen, ist bereits vorhanden. Jedoch ist der Name und der Speicherpfad der Arbeitsmappe nicht bekannt und muss erst ermittelt werden.
Die Quellarbeitsmappe ist geschlossen und befindet sich im Unterverzeichnis „Quelle“ der Zielarbeitsmappe. Die Daten befinden sich in der Tabelle1 und sind von dort zu kopieren.
In der Zielarbeitsmappe ist eine Tabelle mit dem Namen „Log“ vorhanden, in das Meldungen geschrieben werden.
VBA-Code
Option Explicit
Sub Import_Rohdaten()
Application.ScreenUpdating = False ' Screenupdating ausschalten
If MsgBox("Bitte prüfen Sie vor dem Beginn der Daten-Imports, dass in der Rohdaten-Datei" _
& Chr(10) & _
"nur eine Tabelle mit dem Namen vorhanden ist." _
& Chr(10) _
& Chr(10) _
& Chr(10) & _
"Möchten Sie mit dem Import fortfahren?", vbYesNo, "Import Rohdaten") = vbYes Then
Worksheets("Import").Select
Range("A1").Select
Call ImportiereRohdaten
Else
Worksheets("Log").Range("b3").Value = Date & " - " & Time & " - Daten-Import abgebrochen."
Worksheets("Log").Select
End If
Application.ScreenUpdating = True ' Screenupdating einschalten
End Sub
Private Sub ImportiereRohdaten()
Application.ScreenUpdating = False ' Screenupdating ausschalten
Dim strArbeitsmappe_Pfad As String
Dim strArbeitsmappe_Name As String
Dim strArbeitsmappe_Tabellenblatt As String
Dim strArbeitsmappe As String
Dim strVerzeichnis As String
Dim StrDatei As String
Dim I As Integer
Dim StrTyp As String
Dim Dateiname As String
Dim Dateiname_neu As String
Dim Zeit As Date
Dim strQuelle_Workbook As String
' Definiert den Pfad der geöffneten Arbeitsmappe (= Zielarbeitsmappe)
' Der Pfad der geöffneten Arbeitsmappe (= Zielarbeitsmappe) wird jedesmal neu ermittelt.
strArbeitsmappe_Pfad = ThisWorkbook.Path & ""
' Definiert den Datei-Namen der geöffneten Arbeitsmappe (= Zielarbeitsmappe)
' Der Name wird jedesmal neu ermittelt.
strArbeitsmappe_Name = ThisWorkbook.Name
' Definiert das Tabellenblatt in der geöffneten Arbeitsmappe (= Zielarbeitsmappe), in das die Rohdaten importiert werden
' Der Name des Tabellenblatts wird jedesmal neu ermittelt.
' ACHTUNG: Der Cursor muss sich zwingend in der Tabelle befinden
strArbeitsmappe_Tabellenblatt = ActiveSheet.Name ' Ziel-Tabellenblatt
' Definiert den Quellpfad der die Arbeitsmappe mit Rohdaten (= Quelle) enthält
' ACHTUNG: Das Unterverzeichnis ist anzupassen
strVerzeichnis = ThisWorkbook.Path & "\Quelle"
' Definiert den Datei-Typ, der die Rohdaten (= Quelle enthält
StrTyp = "*.xlsx"
Dateiname = Dir(strVerzeichnis & StrTyp)
Dateiname_neu = Dateiname
Zeit = FileDateTime(strVerzeichnis & Dateiname)
' Definiert den Namen der Arbeitsmappe, die die Rohdaten (= Quelle enthält
strQuelle_Workbook = strVerzeichnis & Dateiname_neu ' neu
' Aktiviert die Ziel-Tabelle
Worksheets(strArbeitsmappe_Tabellenblatt).Activate
Range("A1").Activate
' Sucht im Quell-Verzeichnis nach der neuesten Excel-Arbeitsmappe
Do While Dateiname <> ""
If Zeit < FileDateTime(strVerzeichnis & Dateiname) Then
Zeit = FileDateTime(strVerzeichnis & Dateiname)
Dateiname_neu = Dateiname
End If
Dateiname = Dir
Loop
If MsgBox("Es wurde die Datei - " & Dateiname_neu & " - für den Import ausgewählt." & _
Chr(10) & _
Chr(10) & _
"Möchten Sie die Daten importieren?", vbYesNo, "Import Rohdaten") = vbYes Then
' In der Zielarbeitsmappe wird der Bereich gelöscht
Sheets(strArbeitsmappe_Tabellenblatt).Select
' Ermittelt die letzte befüllte Zelle
Dim Letzte_Ziel As Long
Letzte_Ziel = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
' Ermittelt die letzte befüllte Zelle
Range("A1:R" & Letzte_Ziel).Select
Selection.Clear
' Öffnet die Arbeitsmappe mit den Rohdaten (= Quelle)
Workbooks.Open (ThisWorkbook.Path & "\Quelle" & Dateiname_neu)
Sheets("Tabelle1").Activate
' Prüft den Spaltennamen in der Quell-Datei auf Übereinstimmungauf
' Entspricht die Spaltenüberschrift nicht den Vorgaben, wird der Import abgebrochen
If ActiveSheet.Range("C1").Value = "Spaltenüberschrift" Then
'MsgBox ("Spaltename C der Rohdaten entspricht den Vorgaben")
' Ermittelt die letzte befüllte Zelle
Dim Letzte_Roh As Long
Letzte_Roh = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
' Ermittelt die letzte befüllte Zelle
Range("A1:R" & Letzte_Roh).Copy
' Aktiviert die Zielarbeitsmappe und fügt die kopierten Daten ein
Windows(strArbeitsmappe_Name).Activate
Worksheets(strArbeitsmappe_Tabellenblatt).Activate
Range("A1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Wechselt auf die Rohdaten-Datei und schließt diese
Windows(Dateiname_neu).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
' Wechselt zur Zielarbeitsmappe und setzt den Cursor in die Zelle A1
Windows(strArbeitsmappe_Name).Activate
Worksheets(strArbeitsmappe_Tabellenblatt).Activate
Range("a1").Select
' Schreibt in den Log-Bereich in Tabelle "Dashboard"
Worksheets("Log").Range("b3").Value = Date & " - " & Time & " - Daten-Import erfolgreich abgeschlossen."
Worksheets("Log").Select
' Wenn der Spaltenname nicht den Vorgaben entspricht, wird der Import abgebrochen
Else
'MsgBox "Abbruch - Falsche Spaltenbenennung."
' Wechselt auf die Rohdaten-Datei und schließt diese
Windows(Dateiname_neu).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
' Wechselt zur Zielarbeitsmappe und setzt den Cursor in die Zelle A1
Windows(strArbeitsmappe_Name).Activate
Worksheets(strArbeitsmappe_Tabellenblatt).Activate
Range("a1").Select
MsgBox "Daten-Import abgebrochen - Falsche Spaltenbenennung in den Rohdaten. Bitte prüfen Sie das Log-File."
Worksheets("Log").Range("b3").Value = Date & " - " & Time & " - Daten-Import abgebrochen - falsche Spaltenbenennung in den Rohdaten. Spalte C <> Spaltenüberschrift."
Worksheets("Log").Select
End If
Else
MsgBox "Der Import wurde abgebrochen."
Worksheets("Log").Range("b3").Value = Date & " - " & Time & " - Daten-Import abgebrochen."
Worksheets("Log").Select
End If
Application.ScreenUpdating = True ' Screenupdating einschalten
End Sub
ist absolut technik-begeistert und großer Fan von Linux und Open Source. Raspberry Pi Bastler der ersten Stunde und nach wie vor begeistert von dem kleinen Stück Hardware, auf dem er tolle Projekte umsetzt. Teilt hier seine Erfahrungen mit Nextcloud, Pi-hole, YubiKey, Synology und openmediavault und anderen spannenden IT-Themen. Nutzt Markdown und LaTeX zum Dokumentieren seiner Projekte und Gitea zum Versionieren. Sitzt vor einem 49“ Monitor, nutzt Windows und MacOS zum Arbeiten, Linux auf seinen Servern und virtuellen Maschinen und hört dabei Spotify und MP3s und Radio-Streams über seinen RadioPi.
Trinkt gerne fairen Kaffee und freut sich deshalb sehr über jede Spende.
• 
