Makro für Exceltabellenauslesung/Zusammenfassung

Guten Morgen,
Makros sind überhaupt nicht mein Ding.
Vielleicht könnte mir jemand auf die Sprünge helfen :-/
Ich möchte in einem Ordner alle Exceltabellen eine bestimmte Spalte nach Namen durchsuchen lassen und den Wert der direkt daneben steht in einer Gesamtübersicht (andere Exceltabelle, in einer bestimmten Reihenfolge) zusammenfassen.
Die Quelltabellen in dem Ordner sind inhaltlich (bis auf den Wert) immer gleich und sehen immer so aus:
Produktionsbericht vom XX.XX.XXXX
Produktionsbericht vom XY.XX.XXXX
etc.
Daten stehen jeweils im Reiter 2 (Name:Eingabe Zeiten) des jeweiligen Produktionsberichtes:
Spalte 1________Spalte 2
Abteilung1______Stundenanzahl
Abteilung2______Stundenanzahl
etc_____________etc
Ziel ist es eine Übersichtstabelle zu erstellen die immer automatisch im Ordner alle Produktionsberichte im Reiter2 nach den Abteilungsnamen sucht und sich die Werte merkt.
Diese sollen dann wie folgt in der Zieldatei ausgegeben werden:
Dateiname____________________________Abteilung1__Abteilung 2 etc
Produktionsbericht vom XX.XX.XXXX_________Wert_______Wert
Produktionsbericht vom XY.XX.XXXX_________Wert_______Wert
....
Kann mir bitte bitte jemand helfen ?
Danke, Sebastian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
danke für die Antwort.
Suchfunktion nutzen kann ich auch, Module bereits kopiert habe ich.
Jedoch funktioniert es nicht so wie ich will.
Könnte es jemand abändern ?

Sub GetData()
Dim oMe As Object, sSuchbegriff(), sBereich As String, iZeile As Integer, sKennz As String
Dim iSbMax As Integer, iLK As Integer, i As Integer, sWbName As String, rFound As Range, vWert  _
As Variant
Dim oFS As Object, oDatei As Object, wsTabelle As Worksheet, bEintrag As Boolean
Set oMe = ThisWorkbook.Worksheets("Tabelle1") 'Zieltabelle (in der gerade geöffneten Datei)
iZeile = 2 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen
Const sDateiPfad As String = "C:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash  _
am Ende
sKennz = "Produktionsbericht" 'Nur Tabellen, deren Name mit dem Kennzeichen beginnt,  _
verarbeiten
sSuchbegriff = Array("Produktionsleitung spät:", "Produktionsleitung früh:", "Sortierung:") ' _
Liste der Suchbegriffe
sBereich = "A1:A100"
iSbMax = UBound(sSuchbegriff) 'Höchster Index der Suchbegriffmatrix
iLK = Len(sKennz) 'Länge des Tabellennamen-Kennzeichens
Set oFS = CreateObject("Scripting.FileSystemObject")
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
sWbName = oDatei.Name
Workbooks.Open (oDatei.Path)
For Each wsTabelle In Workbooks(sWbName).Worksheets()
If StrComp(Left(wsTabelle.Name, iLK), sKennz, vbTextCompare) = 0 Then
bEintrag = False
For i = 0 To iSbMax
Set rFound = wsTabelle.Range(sBereich).Find(sSuchbegriff(i), LookIn:=xlValues)
If Not rFound Is Nothing Then
vWert = wsTabelle.Cells(rFound.Row, rFound.Column + 1).Value
oMe.Cells(iZeile, i + 1).Value = vWert
bEintrag = True
End If
Next
If bEintrag Then iZeile = iZeile + 1 'mindestens ein Eintrag erfolgt, daher neue  _
Zeile
End If
Next
Workbooks(sWbName).Saved = True
Workbooks(sWbName).Close
Next
End Sub

Suche nur im Reiter 2 (Eingabe Zeiten) in jeder Datei im Ordner und Formatierung / Anordnung in der Zieldatei klappt nicht so, wie ich es in der Anfrage formuliert hatte.
Könnte es mir jemand abändern, bitte ?
Gruß

Function GetColumn(ws As Worksheet, a As String) As Long Dim s As String, c As Long c = 2: s = ws.Cells(1, c) While s "" If s = a Then GetColumn = c: Exit Function c = c + 1: s = ws.Cells(1, c) Wend GetColumn = c End Function Sub GetData() Const Quellpfad As String = "C:\Test\" 'Pfad zum durchsuchen mit Backslash hinten Const Dateimaske As String = "Produktionsbericht vom *.xlsx" Dim Datei As String, Quellsheet As Worksheet, qr As Long Dim Ausgabe As Worksheet, r As Long, c As Long Dim s As String Workbooks.Add Set Ausgabe = ActiveWorkbook.Worksheets("Tabelle1") r = 2 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen Datei = Dir(Quellpfad + Dateimaske, vbNormal) While Datei "" Workbooks.Open Quellpfad + Dateimaske Set Quellsheet = ActiveWorkbook.Worksheets("Tabelle2") qr = 1: s = Cells(qr, 1) While (s "") If Left(s, 9) = "Abteilung" Then Ausgabe.Cells(r, 1) = Datei c = GetColumn(Ausgabe, s) Ausgabe.Cells(r, c) = Quellsheet.Cells(qr, 2) r = r + 1 End If qr = qr + 1: s = Cells(qr, 1) Wend ActiveWorkbook.Close False Datei = Dir() Wend End Sub

Sub iFen() Dim WSZ As Worksheet: Set WSZ = ActiveSheet Dim WBQ As Workbook 'Quelle iPath = ThisWorkbook.Path & "\" iFile = Dir(iPath & "Sebastian Bsp*.xlsx") '>>>> lrZ = WSZ.Cells(Rows.Count, "A").End(xlUp).Row '1. freie Zeile im Ziel-Blatt Do While Len(iFile) lrZ = lrZ + 1 Set WBQ = Workbooks.Open(iPath & iFile) With WBQ.Sheets("Eingabe Zeiten") lr = .Cells(Rows.Count, "B").End(xlUp).Row With .Range("B14:B" & lr) .Value = .Value .SpecialCells(2).Copy End With WSZ.Cells(lrZ, 1) = iFile WSZ.Cells(lrZ, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End With WBQ.Close 0 iFile = Dir Loop End Sub

Sub iFen() Dim WSZ As Worksheet: Set WSZ = ActiveSheet Dim WBQ As Workbook 'Quelle iPath = ThisWorkbook.Path & "\" iFile = Dir(iPath & "Produktionsbericht*.xls") '>>>> lrZ = WSZ.Cells(Rows.Count, "A").End(xlUp).Row '1. freie Zeile im Ziel-Blatt Do While Len(iFile) lrZ = lrZ + 1 WSZ.Cells(lrZ, 1) = iFile Set WBQ = Workbooks.Open(iPath & iFile) WBQ.Sheets("Eingabe Zeiten").Range(cells(14,2),cells(rows.count, "B").end(xlup).row).value. _ specialcells(2).copy WSZ.Cells(lrZ, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True WBQ.Close 0 iFile = Dir Loop End Sub

Sub iFen() Dim WSZ As Worksheet: Set WSZ = ActiveSheet Dim WBQ As Workbook 'Quelle iPath = ThisWorkbook.Path & "\" iFile = Dir(iPath & "Produktionsbericht*.xls") '>>>> lrZ = WSZ.Cells(Rows.Count, "A").End(xlUp).Row '1. freie Zeile im Ziel-Blatt Do While Len(iFile) lrZ = lrZ + 1 Set WBQ = Workbooks.Open(iPath & iFile) With WBQ.Sheets("Tabelle2") lr = .Cells(Rows.Count, "B").End(xlUp).Row With .Range("B14:B" & lr) .Value = .Value .SpecialCells(2).Copy End With WSZ.Cells(lrZ, 1) = iFile WSZ.Cells(lrZ, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End With WBQ.Close 0 iFile = Dir Loop End Sub

Sub iFen() Dim WSZ As Worksheet: Set WSZ = ActiveSheet Dim WBQ As Workbook 'Quelle iPath = ThisWorkbook.Path & "\" 'iPath = "c:\temp\" '>>>> lrZ = WSZ.Cells(Rows.Count, "A").End(xlUp).Row '1. freie Zeile im Ziel-Blatt Do While Len(iFile) lrZ = lrZ + 1 Set WBQ = Workbooks.Open(iPath & iFile) With WBQ.Sheets("Eingabe Zeiten") lr = .Cells(Rows.Count, "B").End(xlUp).Row With .Range("B14:B" & lr) .Value = .Value .SpecialCells(2).Copy End With WSZ.Cells(lrZ, 1) = iFile WSZ.Cells(lrZ, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End With WBQ.Close 0 iFile = Dir Loop End Sub

Beliebteste Forumthreads (12 Monate)

Makro für Exceltabellenauslesung/Zusammenfassung

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread