Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1108to1112
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Sepp Help - Ordner auslesen

Sepp Help - Ordner auslesen
Sandra
Hallo lieber Sepp,
ich brauhe nochmals Deine Hilfe! Stehe vor einem großen Problem.
Meine Datei enthält derzeit ein Blatt namens Übersicht. In der ersten Zeile befinden sich Überschriften.
Ab Zeile 2 befinden sich in Spalte A Dateinamen und in Spalte B Reiternamen.
Nun soll jede dort aufgeführte Datei geöffnet und der in Spalte B befindlicher Reiternamen in meine Datei kopiert werden. Vor diesem Kopieren sollen alle Reiter ausser meiner Übersicht gelöscht werden. Hintergrund: Der job wird einmal tätglich gemacht. In Spalte C soll eingetragen werden, ob das kopieren erfolgreich war. Es kann ja sein, dass eine Tabelle oder eine ganze Datei ja nicht vorhanden ist. Die Dateien befinden sich nicht im gleichen Ordner, so dass man den vollständigen Dateinamen incl. Pfad wohl angeben muss.
Derzeit mache ich das per Hand und das ist ziemlich viel Arbeit. Kannst Du mir hier helfen?
Vielen lieben Dank!
Liebe Grüße
Sandra

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
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

Anzeige
@ Sepp: vielen vielen Dank!
23.10.2009 08:54:47
Sandra
Es klappt perfekt. Nochmals Danke für Deine Hilfe!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige