Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 08:08:24
Pivot Vormonatsveränderung
26.04.2024 07:54:11
nur den ersten Eintrag in spalte zählen
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1828to1832
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1828to1832
1828to1832
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Auslesen von Dateien

Auslesen von Dateien
10.05.2021 14:16:35
Dateien
Hallo,
ich habe ein Makro Dies habe ich mal aus diesem Forum bekommen.
Dies funktioniert auch. Es geht alle Excel-Dateien im Zielpfad duch und gibt mir definierte Felder wieder. Somit habe ich aus vielen Einzeldateien dann eine Gesamtdatei/ -liste.
Nun hab ich 2 Fragen an euch:
1. Die auszulesenden Dateien haben hier immer das Tabellenblatt "Vorlage" aus dem dann die Felder gezogen werden. Nun habe ich auch viele Dateien, die vielleicht Vorlage1, Übersicht, oder Tabelle1 heißen. Wie kann ich es umschreiben, dass er alle Tabellenblätter der Datei zieht und auswertet?
2. Der Ort der auszulesenden Dateien ist ein Ordner. Unterordner werden nicht einbezogen. Wie kann ich es umschreiben, dass er den Ordner und alle Unterordner mit einbezieht?
Danke euch.
Option Explicit

Public Sub ExcelDateienAuswerten()
Dim strDateiname As String
Dim strPfad      As String
Dim lngZeile     As Long
'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xlsx) liegen
strPfad = "G:\Maßnahmen\"
'Den 1. Dateinamen holen
strDateiname = Dir(strPfad & "*.xlsx")
'Startzeile festlegen
lngZeile = 4
'Solange ein Dateiname gelesen wird
Do While Not strDateiname = ""
'Datei verarbeiten
Call TabVerarb(strPfad & strDateiname, lngZeile)
'nächsten Dateinamen holen
strDateiname = Dir()
'Zeilenzähler erhöhen
lngZeile = lngZeile + 1
Loop
End Sub


Public Sub TabVerarb(strPfad As String, lngZeile As Long)
Dim strMeSH As String
Dim strDatei As String
Dim strSH As String
'Dateinamen extrahieren
strDatei = Split(strPfad, "\")(UBound(Split(strPfad, "\")))
'Eigenen Namen merken
strMeSH = ActiveWorkbook.Name
'Datei öffnen
Workbooks.Open Filename:=strPfad
With Workbooks(strMeSH)
'Dateinamen und auszuwertenden Zellen übertragen
.Sheets("Tabelle1").Cells(lngZeile, 1) = strDatei
.Sheets("Tabelle1").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("Vorlage").Range("G4").Value
.Sheets("Tabelle1").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("Vorlage").Range("B4").Value
.Sheets("Tabelle1").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("Vorlage").Range("G7").Value
.Sheets("Tabelle1").Cells(lngZeile, 5) = Workbooks(strDatei).Sheets("Vorlage").Range("B2").Value
.Sheets("Tabelle1").Cells(lngZeile, 6) = Workbooks(strDatei).Sheets("Vorlage").Range("B28").Value
.Sheets("Tabelle1").Cells(lngZeile, 7) = Workbooks(strDatei).Sheets("Vorlage").Range("G28").Value
.Sheets("Tabelle1").Cells(lngZeile, 8) = Workbooks(strDatei).Sheets("Vorlage").Range("B45").Value
.Sheets("Tabelle1").Cells(lngZeile, 9) = Workbooks(strDatei).Sheets("Vorlage").Range("B49").Value
.Sheets("Tabelle1").Cells(lngZeile, 10) = Workbooks(strDatei).Sheets("Vorlage").Range("C45").Value
.Sheets("Tabelle1").Cells(lngZeile, 11) = Workbooks(strDatei).Sheets("Vorlage").Range("C49").Value
.Sheets("Tabelle1").Cells(lngZeile, 12) = Workbooks(strDatei).Sheets("Vorlage").Range("D45").Value
.Sheets("Tabelle1").Cells(lngZeile, 13) = Workbooks(strDatei).Sheets("Vorlage").Range("E45").Value
.Sheets("Tabelle1").Cells(lngZeile, 14) = Workbooks(strDatei).Sheets("Vorlage").Range("E49").Value
.Sheets("Tabelle1").Cells(lngZeile, 15) = Workbooks(strDatei).Sheets("Vorlage").Range("F45").Value
.Sheets("Tabelle1").Cells(lngZeile, 16) = Workbooks(strDatei).Sheets("Vorlage").Range("F49").Value
.Sheets("Tabelle1").Cells(lngZeile, 17) = Workbooks(strDatei).Sheets("Vorlage").Range("G45").Value
.Sheets("Tabelle1").Cells(lngZeile, 18) = Workbooks(strDatei).Sheets("Vorlage").Range("G49").Value
.Sheets("Tabelle1").Cells(lngZeile, 19) = Workbooks(strDatei).Sheets("Vorlage").Range("H45").Value
.Sheets("Tabelle1").Cells(lngZeile, 20) = Workbooks(strDatei).Sheets("Vorlage").Range("H49").Value
End With
'Quelldatei schließen
Workbooks(strDatei).Saved = True
Workbooks(strDatei).Close
End Sub

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

Betreff
Datum
Anwender
Anzeige
AW: Auslesen von Dateien
10.05.2021 15:48:42
Dateien
Hallo Björn,
teste mal:
Code:



[Cc][+][-]







	
	
	
	




Option Explicit

Public Sub ExcelDateienAuswerten()

  Const FOLDER_PATH As String = "G:\Maßnahmen\"

  Dim astrFolders() As String, strFilename As String
  Dim ialngFolders As Long, lngRow As Long

  ' Startzeile festlegen
  lngRow = 4

  ' Ordner und alle Unterordner holen
  astrFolders = GetFolders(FOLDER_PATH)

  ' Schleife über über Ordner
  For ialngFolders = LBound(astrFolders) To UBound(astrFolders)

      ' Den 1. Dateinamen des Ordners holen
      strFilename = Dir$(astrFolders(ialngFolders) & "*.xlsx")

      ' Solange ein Dateiname gelesen wird
      Do Until strFilename = vbNullString

         ' Datei verarbeiten
         Call CopyValues(astrFolders(ialngFolders) & strFilename, lngRow)

         ' nächsten Dateinamen holen
         strFilename = Dir$

      Loop
  Next
End Sub

Private Sub CopyValues(ByVal pvstrPath As String, ByRef prlngRow As Long)

  Dim objWorkbook As Workbook
  Dim objWorksheet As Worksheet

  ' Datei öffnen
  Set objWorkbook = Workbooks.Open(Filename:=pvstrPath)

  ' Schleife über alle Tabellen
  For Each objWorksheet In objWorkbook.Worksheets

      With ThisWorkbook.Worksheets("Tabelle1")

          ' Dateinamen und auszuwertenden Zellen übertragen
          .Cells(prlngRow, 1).Value = objWorkbook.Name
          .Cells(prlngRow, 2).Value = objWorksheet.Range("G4").Value
          .Cells(prlngRow, 3).Value = objWorksheet.Range("B4").Value
          .Cells(prlngRow, 4).Value = objWorksheet.Range("G7").Value
          .Cells(prlngRow, 5).Value = objWorksheet.Range("B2").Value
          .Cells(prlngRow, 6).Value = objWorksheet.Range("B28").Value
          .Cells(prlngRow, 7).Value = objWorksheet.Range("G28").Value
          .Cells(prlngRow, 8).Value = objWorksheet.Range("B45").Value
          .Cells(prlngRow, 9).Value = objWorksheet.Range("B49").Value
          .Cells(prlngRow, 10).Value = objWorksheet.Range("C45").Value
          .Cells(prlngRow, 11).Value = objWorksheet.Range("C49").Value
          .Cells(prlngRow, 12).Value = objWorksheet.Range("D45").Value
          .Cells(prlngRow, 13).Value = objWorksheet.Range("E45").Value
          .Cells(prlngRow, 14).Value = objWorksheet.Range("E49").Value
          .Cells(prlngRow, 15).Value = objWorksheet.Range("F45").Value
          .Cells(prlngRow, 16).Value = objWorksheet.Range("F49").Value
          .Cells(prlngRow, 17).Value = objWorksheet.Range("G45").Value
          .Cells(prlngRow, 18).Value = objWorksheet.Range("G49").Value
          .Cells(prlngRow, 19).Value = objWorksheet.Range("H45").Value
          .Cells(prlngRow, 20).Value = objWorksheet.Range("H49").Value

      End With

      ' Zeilenzähler erhöhen
      prlngRow = prlngRow + 1

  Next

  ' Quelldatei schließen
  Call objWorkbook.Close(SaveChanges:=False)

  ' Objekt freigeben
  Set objWorkbook = Nothing

End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()

  Dim astrFolders() As String
  Dim strFolder As String, strPath As String
  Dim ialngIndex1 As Long, ialngIndex2 As Long

  ReDim Preserve astrFolders(ialngIndex1)
  astrFolders(ialngIndex1) = pvstrPath
  ialngIndex1 = 1
  ialngIndex2 = 1

  strPath = pvstrPath

  Do

     strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)

     Do Until strFolder = vbNullString

        If strFolder <> "." And strFolder <> ".." Then

           If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then

              ReDim Preserve astrFolders(0 To ialngIndex1)
              astrFolders(ialngIndex1) = strPath & strFolder & "&bsol;"
              ialngIndex1 = ialngIndex1 + 1

           End If
        End If

        strFolder = Dir$

     Loop

     If ialngIndex1 = ialngIndex2 Then Exit Do

     strPath = astrFolders(ialngIndex2)

     ialngIndex2 = ialngIndex2 + 1

  Loop

  GetFolders = astrFolders

End Function
Gruß
Nepumuk
Anzeige
AW: Auslesen von Dateien
10.05.2021 16:11:27
Dateien
Hallo Nepumuk,
Danke für deine Hilfe. Ich habe versucht zu verstehen was du machst. Ich bin leider Laie, aber zumindest kann ich es grob nachvollziehen.
Ich habe es getestet und es funktioniert tadellos. ZUmindest mit meinen Beipsieldateien.
Morgen werde ich es ausführlich testen.
Danke dir vielmals.

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige