AW: Sepp Help - Ordner auslesen
22.10.2009 21:31:38
Josef
Hallo Sandra,
in Spalte A ab Zeile 2 stehen die Dateinamen inkl. Pfad, in Spalte B stehen die Tabellennamen, in Spalte C wird der Status eingetragen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importSheets()
Dim objSh As Worksheet, objDel As Worksheet, objWb As Workbook
Dim lngRow As Long, lngLast As Long
On Error GoTo ErrExit
GMS
Set objSh = Sheets("Übersicht")
With objSh
For Each objDel In .Parent.Worksheets
If Not objDel Is objSh Then objDel.Delete
Next
lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
.Range("C2:C" & Rows.Count).ClearContents
For lngRow = 2 To lngLast
If .Cells(lngRow, 1) <> "" Then
If Dir(.Cells(lngRow, 1).Text, vbNormal) <> "" Then
Set objWb = Workbooks.Open(.Cells(lngRow, 1).Text)
If SheetExist(.Cells(lngRow, 2).Text, objWb) Then
objWb.Sheets(.Cells(lngRow, 2).Text).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
.Cells(lngRow, 3) = "Importiert"
Else
.Cells(lngRow, 3) = "Tabelle nicht vorhanden"
End If
objWb.Close False
Else
.Cells(lngRow, 3) = "Datei nicht vorhanden"
End If
End If
Next
.Activate
End With
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 objWb = Nothing
Set objSh = Nothing
Set objDel = Nothing
End Sub
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
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Gruß Sepp