VBA-Tabellenblatt einlesen

Forumthread: VBA-Tabellenblatt einlesen

31.01.2007 21:03:33

Peter

Hallo Forum,
ich würde mich über Hilfe sehr freuen.
Danke im voraus Peter
-siehe Bsp-
https://www.herber.de/bbs/user/40041.xls
Ich möchte den Inhalt von 2 namensgleichen Tabellenblättern von
einer Quelldatei in die Zieldatei kopieren.
Dabei soll gleichzeitig eine Fehlerbehandlung durchgeführt werden.
1.es soll überprüft werden ob die Datei sich im vorgegebenen Verzeichnis befindet.
2.befindet sich die Datei im vorgegebenen Verzeichnis, soll die Datei geöffnet werden
3.ist die Datei nicht offen soll die Datei geöffnet werden
4.ist die Datei bereits offen soll überprüft werden ob sich in der Quelldatei ein namensgleiches Tabellenblatt befindet
5.der Kopiervorgang innerhalb der namensgleichen Tabellenblätter wird durchgeführt und danach die Quelldatei geschlossen
siehe Versuch:

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: VBA-Tabellenblatt einlesen

02.02.2007 02:13:57

fcs
Vielen Dank

04.02.2007 16:22:07

Peter

AW: VBA-Tabellenblatt einlesen

02.02.2007 02:13:57

fcs

Hallo Peter,
mit folgenden Anpassungen werden die entsprechenden Prüfungen durchgeführt
Gruss
Franz


Option Explicit
Public QDatei As String, QPfad As String, Blatt As String
Sub DateiCheck()
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
QDatei = "Inventar.xls"
QDatei = "Datei1.xls"
QPfad = "D:\Abt\Zimmer"
Blatt = "Raum1" 'Name des Tabellenblatts dessen Inhalt kopiert werden soll
'********Existiert die Quelldatei ? ***************************************************
If Dir(QPfad & "\" & QDatei) = "" Then
MsgBox " Die Datei """ & QPfad & "\" & QDatei & """ existiert nicht"
End If
'********Arbeitsmappe offen ? *********************************************************
If DateiOffen(QDatei) = True Then
'********Pfad korrekt ? **********************************************************
If Workbooks(QDatei).Path = QPfad Then
MsgBox "Arbeitsmappe ist offen"
Else
MsgBox "Der Pfad der geöffneten Quelldatei stimmt nicht" & vbLf & vbLf _
& "Datei wird geschlossen und korrekte Datei geöffnet"
Workbooks(QDatei).Close savechanges:=False
Workbooks.Open (QPfad & "\" & QDatei)
End If
Else
MsgBox "Arbeitsmappe wird geöffnet"
Workbooks.Open (QPfad & "\" & QDatei)
End If
'********Tabellenblatt vorhanden ? ****************************************************
If Tabellevorhanden(Workbooks(QDatei), Blatt) = True Then
Call Kopieren
Else
MsgBox "Tabellenblatt """ & Blatt & """ in Quelldatei nicht vorhanden"
End If
Workbooks(QDatei).Close savechanges:=False
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ERRORHANDLER:
MsgBox " Das Verzeichnis """ & QPfad & """ existiert nicht"
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function DateiOffen(QDatei As String) As Boolean
'Prüfung ob Arbeitsmappe geöffnet
Dim wkb As Workbook
On Error GoTo Fehler
For Each wkb In Workbooks
If wkb.Name = QDatei Then
DateiOffen = True
Exit Function
End If
Next
Fehler:
DateiOffen = False
End Function
Function Tabellevorhanden(wkb As Workbook, Tabellenname As String) As Boolean
'Prüfung ob Tabellenblatt in Arbeitsmappe vorhanden
Dim wks As Worksheet
On Error GoTo Fehler
For Each wks In wkb.Worksheets
If wkb.Name = Tabellenname Then
Tabellevorhanden = True
Exit Function
End If
Next
Fehler:
Tabellevorhanden = False
End Function
Sub Kopieren()
Dim LRow As Long
Dim QSh As Worksheet, ZSh As Worksheet
Set QSh = Workbooks(QDatei).Worksheets(Blatt)
Set ZSh = ThisWorkbook.Worksheets(Blatt)
LRow = QSh.Cells(Rows.Count, 9).End(xlUp).Row
ZSh.Range(ZSh.Cells(1, 1), ZSh.Cells(LRow, 80)).Value = _
QSh.Range(QSh.Cells(1, 1), QSh.Cells(LRow, 80)).Value
ZSh.Columns.AutoFit
End Sub

Vielen Dank

04.02.2007 16:22:07

Peter

Hallo Franz,
Nochmals Danke.
Genauso hab ich es gemeint.
Werde ich gleich ausprobieren.
Peter

Infobox / Tutorial

Schritt-für-Schritt-Anleitung

Um den Inhalt von zwei namensgleichen Tabellenblättern aus einer Quelldatei in eine Zieldatei zu kopieren, kannst du den folgenden VBA-Code verwenden. Stelle sicher, dass du die richtige Excel-Version nutzt, die VBA unterstützt (Excel 2007 oder höher).

Öffne Excel und drücke ALT + F11, um den VBA-Editor zu öffnen.
Füge ein neues Modul hinzu, indem du im Projekt-Explorer mit der rechten Maustaste auf "VBAProject" klickst und "Einfügen" > "Modul" auswählst.
Kopiere den folgenden Code in das Modul:

Option Explicit
Public QDatei As String, QPfad As String, Blatt As String

Sub DateiCheck()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo ERRORHANDLER

    QDatei = "Datei1.xls"
    QPfad = "D:\Abt\Zimmer"
    Blatt = "Raum1" ' Name des Tabellenblatts, dessen Inhalt kopiert werden soll

    ' Existiert die Quelldatei?
    If Dir(QPfad & "\" & QDatei) = "" Then
        MsgBox "Die Datei """ & QPfad & "\" & QDatei & """ existiert nicht"
        Exit Sub
    End If

    ' Arbeitsmappe offen?
    If DateiOffen(QDatei) = True Then
        ' Pfad korrekt?
        If Workbooks(QDatei).Path = QPfad Then
            MsgBox "Arbeitsmappe ist offen"
        Else
            MsgBox "Der Pfad der geöffneten Quelldatei stimmt nicht" & vbLf & vbLf & "Datei wird geschlossen und korrekte Datei geöffnet"
            Workbooks(QDatei).Close savechanges:=False
            Workbooks.Open (QPfad & "\" & QDatei)
        End If
    Else
        MsgBox "Arbeitsmappe wird geöffnet"
        Workbooks.Open (QPfad & "\" & QDatei)
    End If

    ' Tabellenblatt vorhanden?
    If Tabellevorhanden(Workbooks(QDatei), Blatt) = True Then
        Call Kopieren
    Else
        MsgBox "Tabellenblatt """ & Blatt & """ in Quelldatei nicht vorhanden"
    End If

    Workbooks(QDatei).Close savechanges:=False
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

ERRORHANDLER:
    MsgBox "Das Verzeichnis """ & QPfad & """ existiert nicht"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Function DateiOffen(QDatei As String) As Boolean
    Dim wkb As Workbook
    On Error GoTo Fehler
    For Each wkb In Workbooks
        If wkb.Name = QDatei Then
            DateiOffen = True
            Exit Function
        End If
    Next
Fehler:
    DateiOffen = False
End Function

Function Tabellevorhanden(wkb As Workbook, Tabellenname As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo Fehler
    For Each wks In wkb.Worksheets
        If wks.Name = Tabellenname Then
            Tabellevorhanden = True
            Exit Function
        End If
    Next
Fehler:
    Tabellevorhanden = False
End Function

Sub Kopieren()
    Dim LRow As Long
    Dim QSh As Worksheet, ZSh As Worksheet
    Set QSh = Workbooks(QDatei).Worksheets(Blatt)
    Set ZSh = ThisWorkbook.Worksheets(Blatt)
    LRow = QSh.Cells(Rows.Count, 9).End(xlUp).Row
    ZSh.Range(ZSh.Cells(1, 1), ZSh.Cells(LRow, 80)).Value = QSh.Range(QSh.Cells(1, 1), QSh.Cells(LRow, 80)).Value
    ZSh.Columns.AutoFit
End Sub

Ändere die Variablen QDatei, QPfad und Blatt, um sie an deine Bedürfnisse anzupassen.
Führe das Makro DateiCheck aus, um den Kopiervorgang zu starten.

Häufige Fehler und Lösungen

Die Datei existiert nicht: Überprüfe den Pfad in der Variable QPfad und stelle sicher, dass die Datei vorhanden ist.
Das Tabellenblatt ist nicht vorhanden: Stelle sicher, dass der Name des Tabellenblatts genau mit dem in der Quelldatei übereinstimmt.
Die Arbeitsmappe ist bereits offen, aber der Pfad stimmt nicht: In diesem Fall schließt das Makro die falsche Datei und öffnet die richtige.

Alternative Methoden

Falls du keine VBA-Lösung verwenden möchtest, kannst du auch die folgenden Methoden ausprobieren:

Power Query: Nutze Power Query, um Daten aus verschiedenen Excel-Dateien zu importieren und zu transformieren.
Kopieren und Einfügen: Manuell die Daten kopieren und in die Zieldatei einfügen, wenn es sich um kleine Datenmengen handelt.

Praktische Beispiele

Angenommen, du hast zwei Excel-Dateien mit jeweils einem Tabellenblatt namens "Raum1". Du kannst die oben beschriebenen Schritte befolgen, um die Daten von "Datei1.xls" in dein aktuelles Arbeitsblatt zu kopieren. Achte darauf, dass die Struktur der Tabellenblätter identisch ist, um Komplikationen zu vermeiden.

Tipps für Profis

Verwende die Option Explicit-Anweisung, um sicherzustellen, dass alle Variablen deklariert sind, was die Fehlerbehebung erleichtert.
Implementiere zusätzliche Fehlerbehandlungen, um verschiedene Szenarien zu berücksichtigen, wie z.B. Datei- oder Pfadänderungen.
Halte deine Makros modular, sodass du Funktionen bei Bedarf leicht anpassen kannst.

FAQ: Häufige Fragen

1. Frage: Welche Excel-Version benötige ich für VBA?
Antwort: Du benötigst Excel 2007 oder höher, um VBA-Makros auszuführen.

2. Frage: Kann ich das Makro auch für andere Dateiformate verwenden?
Antwort: Das Makro ist speziell für .xls-Dateien konzipiert, kann jedoch mit Anpassungen auch für andere Formate verwendet werden.

Beliebteste Forumthreads (12 Monate)