Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Aus einer Serie von Arbeitsmappen einen Bereich sammeln

Gruppe

Interaktion

Problem

Aus einem Quellverzeichnis, das aus einem Dialog auszuwählen ist soll aus allen dort vorhandenen Arbeitsmappen der Bereich "A1:C10" untereinander in dieses Arbeitsblatt kopiert werden.

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

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) 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

Function FileArray(strPath As String, strPattern As String)
   Dim arrDateien()
   Dim intCounter As Integer
   Dim strDatei As String
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
   strDatei = Dir(strPath & strPattern)
   Do While strDatei <> ""
       intCounter = intCounter + 1
       ReDim Preserve arrDateien(1 To intCounter)
       arrDateien(intCounter) = strDatei
       strDatei = Dir()
   Loop
   FileArray = arrDateien
End Function

StandardModule: basMain

Sub DatenImport()
   Dim arr As Variant
   Dim iCounter As Integer, iRow As Integer
   Dim sPath As String
   Application.ScreenUpdating = False
   sPath = GetDirectory( _
      "Bitte Pfad der Quelldateien auswählen:")
   If sPath = "" Then Exit Sub
   arr = FileArray(sPath, "*.xls")
   iRow = 1
   For iCounter = 1 To UBound(arr)
      Workbooks.Open sPath & "\" & arr(iCounter)
      Range("A1:C10").Copy _
         ThisWorkbook.Worksheets("Tabelle1").Cells(iRow, 1)
      ActiveWorkbook.Close savechanges:=False
      iRow = iRow + 10
   Next iCounter
   Application.ScreenUpdating = True
End Sub