Herbers Excel-Forum - das Archiv

' **********************************************************************
' 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, vntName As Variant
  
  
  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
          If InStr(1, .Cells(lngRow, 2).Text, "-") > 0 Then
            vntName = Split(.Cells(lngRow, 2), "-")
          Else
            vntName = Array(.Cells(lngRow, 2).Text, .Cells(lngRow, 2).Text)
          End If
          Set objWb = Workbooks.Open(.Cells(lngRow, 1).Text, UpdateLinks:=True)
          If SheetExist(Trim(vntName(0)), objWb) Then
            objWb.Sheets(Trim(vntName(0))).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Trim(vntName(1))
            .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
      Erase vntName
    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