Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Dateien listen und Blätter in neue Arbeitsmappe kopieren

Gruppe

Kopieren

Problem

Über die erste Schaltfläche sollen alle Excel-Arbeitsmappen eines auszuwählenden Verzeichnisses in Spalte A gelistet werden. Blätter mit vorgegebenem Index sollen kopiert werden.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn zweir Schaltflächen zu.

StandardModule: basMain

Sub ListFiles()
   Dim iCounter As Integer
   Dim sPath As String
   Range("A2:B65536").ClearContents
   sPath = GetDirectory("Bitte ein Verzeichnis auswählen:")
   If sPath = "" Then Exit Sub
   With Application.FileSearch
      .FileType = msoFileTypeExcelWorkbooks
      .LookIn = sPath
      .Execute
      For iCounter = 1 To .FoundFiles.Count
         Cells(iCounter + 1, 1).Value = .FoundFiles(iCounter)
      Next iCounter
   End With
   Columns("A:B").AutoFit
End Sub

Sub CopySheets()
   Dim wkb As Workbook, wkbSource As Workbook
   Dim wks As Worksheet
   Dim iCounter As Integer
   Application.ScreenUpdating = False
   Set wks = ActiveSheet
   On Error GoTo ERRORHANDLER
   Application.EnableEvents = False
   Set wkb = Workbooks.Add(1)
   iCounter = 2
   Do Until IsEmpty(wks.Cells(iCounter, 1))
      If Not IsEmpty(wks.Cells(iCounter, 2)) Then
         Set wkbSource = Workbooks.Open( _
            wks.Cells(iCounter, 1).Value, updatelinks:=False)
         Worksheets(wks.Cells(iCounter, 2).Value).Copy _
            after:=wkb.Worksheets(wkb.Worksheets.Count)
         wkbSource.Close savechanges:=False
      End If
      iCounter = iCounter + 1
   Loop
ERRORHANDLER:
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub
StandardModule: basFunctions

Public Type BROWSEINFO
   hOwner As Long
   pidlRoot As Long
   pszDisplayName As String
   lpszTitle As String
   ulFlags As Long
   lpfn As Long
   lParam As Long
   iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
   Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional msg) As String
   Dim bInfo As BROWSEINFO
   Dim Path As String
   Dim r As Long, x As Long, pos As Integer
   bInfo.pidlRoot = 0&
   If IsMissing(msg) Then
      bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
   Else
      bInfo.lpszTitle = msg
   End If
   bInfo.ulFlags = &H1
   x = SHBrowseForFolder(bInfo)
   Path = Space$(512)
   r = SHGetPathFromIDList(ByVal x, ByVal Path)
   If r Then
      pos = InStr(Path, Chr$(0))
      GetDirectory = Left(Path, pos - 1)
   Else
      GetDirectory = ""
   End If
End Function