Tabellen eines Ordners auslesen und in eine Tabelle zusammenführen

Question

Hallo,

ich stehe mal wieder vor einem VBA-Problem und kann es nicht lösen (trotz ähnlicher Fragen hier) ;-(

Ich habe einen Ordner mit zur zeit 123 Tabellen (es werden täglich mehr), der Aufbau dieser Tabellen ist komplett gleich.
Nun möchte ich bestimmte Werte automatisch in eine andere Tabelle (einfach untereinander) übernehmen, und zwar so:

Tabellen im Ordner (1.xls, 2.xls, 3.xls, usw....)
Hier soll das 1. Tabellenblatt angesprochen werden (Tabelle1)
Alle Werte, die in B10 bis H..... (Ende immer unterschiedlich) sollen in den Bereich E5 bis K ... übernommen werden. Zusätzlich sollen in jeder Zeile
der Wert aus C3 in die Spalte A
der Wert aus C4 in die Spalte B
der Wert aus C5 in die Spalte C
der Wert aus C6 in die Spalte D

Tabelle Auswertung
Ab A5 soll diese Tabelle gefüllt werden

Genial wäre es, wenn man das zusätzlich noch nach Jahren trennen könnte (das Datum steht in der Spalte B der einzelnen Tabellen. Wenn also eine Abfrge wäre ... Wenn B = 2009, dann kopiere die Daten ... ??

Oh jeee ... ich hoffe echt auf Anregungen ....

Viele Grüße - Petra

Answer 1

Hi,

Schau doch mal, ob Du etwas aus dieser Datei für Dich verwenden kannst.

btw: Datum
Was heisst das genau?
Heisst das im Bereich

B10 bis H..... (Ende immer unterschiedlich)

können in den Zellen B10 bis B.... immer unterschiedliche Jahreszahlen stehen? Oder ist das pro Quelldatei immer nur ein und dieselbe Jahreszahl?

Bye
malSchauen

Answer 2

Hi,

.... da brauche ich ja Stunden zum durchwühlen ;-))))

Aber grundsätzlich funktioniert es schonmal - außer der Tatsache, dass die Werte aus C3, C4, C5 und C6 nur einmal pro Tabelle übertragen werden.

In der Spalte B kommen übrigens die Jahre 2008 und 2009 vor, die Trennung der Jahre muss nicht zwingend sein (ich habe mir nur gedacht, dass das Makro schneller ausgeführt wird wenn weniger Daten zu suchen sind ??)

Ich habe mal 2 Tabellen (1.xls und Behandlungen.xls) online gestellt, daraus wird dann - so hoffe ich - ersichtlich was ich meine....

Tabelle 1.xls

http://www.file-upload.net/download-1923734/1.xls.html

Tabelle Behandlungen.xls

http://www.file-upload.net/download-1923730/MB_Behandlungen.xls.html

Vielen Dank schonmal ....

Gruss - Petra

Answer 3

Hallo Petra,

nachfogendes Makro kopiert Dir die Daten aller Dateien in einem Pfad in Deine Übersichtsdatei.

Kopiere das Makro in Deine Datei "MB_Behandlungen.xls" in ein StandardModul und starte es z.B. über eine Befehlsschaltfläche.
Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.

Option Explicit

Const strPath = "C:\Eigene Dateien"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long

Datei = Dir(strPath & "\*.xls")
Do While Datei <> ""
If Right(Datei, 4) = ".xls" Then
GetObject (strPath & "\" & Datei)
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
lngCopyRow = lngFirstRow + (lngLastRow - 10)

With Workbooks(Datei).Sheets(1)
'Behandlungsdaten
.Range("B10:H" & lngLastRow).Copy ActiveSheet.Cells(lngFirstRow, 5)
'Kundenummer
ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3")
'Nachname
ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4")
'Vorname
ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5")
'Abrechnung
ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6")
End With

Workbooks(Datei).Close
End If
Datei = Dir()
Loop
End Sub
In dem Makro musst Du in der Zeile

Const strPath = "C:\Eigene Dateien"noch den Pfad, in dem sich die auszulesenden Dateien, anpassen.

Solltest Du nicht wissen, wie Du den Code in Deine Datei bekommst, dann schau mal auf meiner HP in der Rubrik Anleitungen und dort dann in der Anleitungsnummer 3 nach. Dort stelle ich dazu eine bebilderte Anleitung zur Verfügung, die Dir sicherlich helfen wird.

Bei Fragen melde Dich.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 4

Hi,

sieht schon super gut aus, ansich funktioniert es einwandfrei, allerdings sind nun 2 neue Probleme aufgetaucht:

1. Excel wackelt ;-)) fürchterlich ... man sieht also, dass etwas passiert, ich habe Application.DisplayAlerts = False eingefügt ... doch garantiert wieder an der falschen Stelle ...

2. Es werden auch leere Datensätze übernommen (das hatte ich vorher gar nicht bedacht). Es existieren Tabellen, in denen keine Daten vorhanden sind, diese brauchen dann ja auch gar nicht übertragen werden.
Also brauche ich eine If-Abfrage ... mein Ansatz wäre
If ActiveSheet.Range("B10") = "" Then
doch dann?? es soll ja kein Abbruch erfolgen??


Hier der geänderte Code:

Option Explicit

Const strPath = "C:\Users\Petra\Desktop\Behandlungen"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long

[A5:k65000] = "" 'Alte Eintragungen löschen

Datei = Dir(strPath & "\*.xls")
Application.AskToUpdateLinks = False 'deaktiviert Aktualisierung

Do While Datei <> ""
Application.DisplayAlerts = False 'HIER oder WO ???

If Right(Datei, 4) = ".xls" Then
GetObject (strPath & "\" & Datei)
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
lngCopyRow = lngFirstRow + (lngLastRow - 10)

With Workbooks(Datei).Sheets(1)
If ActiveSheet.Range("B10") = "" Then
'??????? .Range("B10:H" & lngLastRow).Copy ActiveSheet.Cells(lngFirstRow, 5) 'Behandlungsdaten
ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3") 'Kundennummer
ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4") 'Nachname
ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5") 'Vorname
ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6") 'Abrechnung
End With

Workbooks(Datei).Close
End If
Datei = Dir()
Loop
Application.DisplayAlerts = True
End Sub

Answer 5

... ähm wie blöd ....

habe zum Abschalten des Bildschirms den falschen Code angewendet, mit Application.ScreenUpdating = False funktioniert es einwandfrei ..

bleibt also noch 1 Problem ;-)


Gruss - Petra

Answer 6

Hallo Petra,

nachfolgendes Makro sollte das machen, was Du meintest.

Option Explicit

Const strPath = "C:\Eigene Dateien"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long

Application.ScreenUpdating = False

Datei = Dir(strPath & "\*.xls")
Do While Datei <> ""
If Right(Datei, 4) = ".xls" Then
GetObject (strPath & "\" & Datei)
If Workbooks(Datei).Sheets(1).Range("B10") <> 0 Then
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
lngCopyRow = lngFirstRow + (lngLastRow - 10)

With Workbooks(Datei).Sheets(1)
'Behandlungsdaten
.Range("B10:H" & lngLastRow).Copy ActiveSheet.Cells(lngFirstRow, 5)
'Kundenummer
ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3")
'Nachname
ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4")
'Vorname
ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5")
'Abrechnung
ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6")
End With
End If
Workbooks(Datei).Close
End If
Datei = Dir()
Loop
End SubMfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 7

Hallol,

perfekt, nun funkzt es einwandfrei .....

Aber mal noch eine Frage zum Verständnis:

In der Zeile If Right(Datei, 4) = ".xls" Then WOFÜR ist
die 4 ??

Vielen, vielen Dank ;-))


Gruss - Petra

Answer 8

Hallo Petra,

gerne geschehen. Die Zahl 4 steht für 4 Buchstaben. Also wenn der Dateiname von rechts gelesen mit 4 Buchstaben den Text ".xls" ergibt dann....

Danke auch für die Rückmeldung.

So, ich schau dann mal weiter Formel1.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 9

Hi,

@Petra65

.... da brauche ich ja Stunden zum durchwühlen ;-))))

Stimmt auffallend. Das was bei mir da im VBA-Editor landet, ist zwar meist funktionsfähig, aber wie ich zugeben muss, sehr schlecht zu lesen und zu pflegen. Da habe ich noch sehr viel zu üben und zu lernen. Da ist der Code von Coros doch deutlich besser strukturiert/aufgebaut.

Wie es auch sei, Dir wurde von Coros geholfen, und dadurch dass ich für mich das Problem durchdacht habe, kann auch ich anhand des Codes von Coros weiter lernen, wie man entsprrechenden Code aufbauen und strukturieren kann.

Also nichts für ungut...
malSchauen

Answer 10

Hi malSchauen,

Stimmt auffallend. Das was bei mir da im VBA-Editor landet, ist zwar meist funktionsfähig ... ...

Das, was bei mir im VBA-Editor landet (abgesehen von Code-Aufzeichnungen) funktioniert meist leider nicht !!! Ich drehe mich stets im Kreis und finde den Lösungsansatz nicht ;-(

Sei froh, dass Deine Codes, wenn auch etwas unübersichtlich, funktionieren ;-)

Viele Grüße - Petra