Stefan's Weblog

17Feb/150

Daten aus anderer Arbeitsmappe in aktuelle Tabelle kopieren

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

hat dir dieser Artikel gefallen?

Dann abonniere doch diesen Blog per RSS Feed!

Kommentare (0) Trackbacks (0)

Zu diesem Artikel wurden noch keine Kommentare geschrieben.


Leave a comment

Noch keine Trackbacks.

%d Bloggern gefällt das: