AW: Alle Tabellen aus Verzeichnis einlesen
15.10.2009 00:58:59
Josef
Hallo Stefan,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importSheets()
Dim objWB As Workbook, objSh As Worksheet
Dim strPath As String, strShName As String, strFile As String
On Error GoTo ErrExit
GMS
strShName = "Klaus" 'Tabellenname
strPath = "C:\Temp" 'Verzeichnis
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFile = Dir(strPath & "*.xls*")
Set objSh = ActiveSheet
Do While strFile <> ""
Set objWB = Workbooks.Open(strPath & strFile)
If SheetExist(strShName, objWB.Name) Then
objWB.Sheets(strShName).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
objWB.Close False
strFile = Dir
Loop
objSh.Activate
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (importSheets) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / importSheets"
End With
GMS True
Set objSh = Nothing
Set objWB = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Gruß Sepp