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