HERBERS Excel-Forum - die Beispiele

Thema: 1000 Arbeitsblätter aus 1000 Arbeitsmappen einlesen

Home

Gruppe

Allgemein

Problem

Wie kann ich Daten aus allen Arbeitsmappen eines Verzeichnisses in diese Arbeitsmappe kopieren?

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

Sub DatenSammeln()
   Dim wks As Worksheet
   Dim fs As FileSearch
   Dim rng As Range
   Dim iCounter As Integer, iRow As Integer
   Dim sMsg As String, sDir As String
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   On Error GoTo ERRORHANDLER
   sMsg = "Wählen Sie bitte einen Ordner aus:"
   sDir = GetDirectory(sMsg)
   If sDir = "" Then Exit Sub
   Set wks = ActiveSheet
   iRow = 3
   Set fs = Application.FileSearch
   With fs
      .LookIn = sDir
      .FileType = msoFileTypeExcelWorkbooks
      .Execute
      For iCounter = 1 To .FoundFiles.Count
         Workbooks.Open _
            FileName:=.FoundFiles(iCounter), _
            updatelinks:=False
         wks.Cells(iRow - 2, 1).Value = ActiveWorkbook.Name & ":"
         Set rng = RealLastCell(ActiveSheet)
         Set rng = Range(Cells(1, 1), rng)
         rng.Copy wks.Cells(iRow, 1)
         iRow = iRow + rng.Rows.Count + 3
         Application.CutCopyMode = False
         ActiveWorkbook.Close savechanges:=False
      Next iCounter
   End With
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

Function RealLastCell(TheSheet As Worksheet) As Range
   Dim ExcelLastCell As Range
   Dim Row%, Col%, LastRowWithData%, LastColWithData%
   Application.ScreenUpdating = False
   Set ExcelLastCell = TheSheet.Cells.SpecialCells(xlLastCell)
   LastRowWithData = ExcelLastCell.Row
   Row = ExcelLastCell.Row
   Do While Application.CountA(TheSheet.Rows(Row)) = 0 And Row <> 1
      Row = Row - 1
   Loop
   LastRowWithData = Row
   LastColWithData = ExcelLastCell.Column
   Col = ExcelLastCell.Column
   Do While Application.CountA(TheSheet.Columns(Col)) = 0 And Col <> 1
      Col = Col - 1
   Loop
   LastColWithData = Col
   Set RealLastCell = TheSheet.Cells(Row, Col)
End Function

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Arbeitsblatt

Excel Arbeitsblatt verkleinern/vergrößern Arbeitsblatt schützen Kommentare aber noch möglich
Arbeitsblatt speichern Arbeitsblatt als E-Mail versenden
Arbeitsblattname in Zelle anzeigen Arbeitsblatt in neuer Arbeitsmappe speichern
Einfügen v. Werten in ein anderes Arbeitsblatt Namen von Arbeitsblatt in Zelle übernehmen
Arbeitsblatt schützen Allgemeine Frage zur Fehlerbehandlung
allgemeine Fragen zu einer Datenbank Dateneingabe u. Arbeitsblatt kopieren
Hyperlink auf Bereich in Arbeitsblatt Ereignis Arbeitsblatt sperren abfangen
Zugriff auf ein Arbeitsblatt per Kennwort VBA-Code von einem Arbeitsblatt ins nächste ausfüh
Arbeitsblatt ohne Select speichern wenn arbeitsblatt vorhanden makro ausführen
wenn arbeitsblatt vorhanden makro ausführen "Seite einrichten" eines Arbeitsblattes übern
Scrollen im Arbeitsblatt bei Formelbearbeitung allgemein
Neue Daten in ein anderes Arbeitsblatt übertragen Arbeitsblatt als rtf-Datei abspeichern - Wie?
Daten aus anderem Arbeitsblatt suchen und einfügen bestehendes Problem Arbeitsblatt erstellen
Arbeitsblattname in ein Feld schreiben Arbeitsblattwechsel durch Formular unterbinden
Neues Arbeitsblatt erstellen, falls nicht vorhande Arbeitsmappe öffnen, Arbeitsblatt suchen, Text ein
Ansicht nach Arbeitsblatt wechsel Combobox abhängig von offenem Arbeitsblatt
combobox rowsource aus anderem arbeitsblatt Automatisches Speichern einer Arbeitsblatt-Kopie
Checkbox in Arbeitsblatt Zellen in neues Arbeitsblatt kopieren
allgemein: VBA lernen? Indirekt - Funktion für anderes Arbeitsblatt
Hide-Methode-Allgemeine Frage Übergabe eines Arbeitsblattes VBA
Arbeitsblattliste-Hyperlinks erstellen-Formatieren Formelassistent allgemein
Arbeitsblatt-Menüleiste ausgeblendet Macro nur auf jeweiligem Arbeitsblatt
Archivieren externer Dateien in Arbeitsblatt allgemeingültig Blattschutz aufheben
Arbeitsblatt activesheet.name im arbeitsblatt
Arbeitsblatt kopieren mit Namensbezügen