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

Hallo, guten Morgen,

ich muss leider die Frage nochmals nach oben holen, da der Code aus Antwort 6 folgendes nicht berücksichtigt:

Es kann sein, dass in A10 eine 1 steht, aber in A11 eine 2.

Ich möchte nun, dass die Daten folgendermassen übertragen werden, z. B. wenn
B10 <> 0 UND A10 = 1 -> übertragen
B11 <> 0 UND A11 = 2 -> nicht übertragen
usw.

Das Problem ist (so glaube ich), dass der Code nur B10 auf ungleich Null abfängt (ist also B10 ungleich Null, so werden ALLE Daten übertragen).
Ich weiss nun nicht wie kompliziert es ist den Code zu ändern.

Ich hoffe auf Denkanstösse ;-)

Gruss - Petra

Answer 2

hi malSchauen und der rest der welt ^^

hier ein highlight fuer dich und alle anderen motivierten vb freaks *hihi*

gruss nighty

VBAHTML 2.0.0.0 alpha 2 von Lukas Mosimann

ein addinn zum einruecken des codes *mein liebling hrhrrr*

hier der link

vbahtml.origo.ethz.ch/download

Answer 3

Hallo Petra,

Du gibst Dir die Antwort doch bereits selber in Deiner Datei mit Deiner Aussage

Ich möchte nun, dass die Daten folgendermassen übertragen werden, z. B. wenn
B10 <> 0 UND A10 = 1 -> übertragen

Dann änbdere doch auch die Zeile

If Workbooks(Datei).Sheets(1).Range("B10") <> 0 Thenin

If Workbooks(Datei).Sheets(1).Range("B10") <> 0 And Workbooks(Datei).Sheets(1).Range("A10") = 1 Then

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,

Ich glaube ja eher, Petra meint das Zeile für Zeile. Also aus der .Range("B10:H" & lngLastRow) nur die Zeilen zu kopieren, die in SpalteA eine 1 stehen haben. Wenn das so ist, könnte das funktionieren wie folgt (Code aus AW6 abgeändert):

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long
Dim lngCount 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 = 0

With Workbooks(Datei).Sheets(1)
For lngCount = 10 To lngLastRow
If .Range("A" & lngCount).Value = 1 Then
'Behandlungsdaten
.Range("B" & lngCount & ":H" & lngCount).Copy _
ActiveSheet.Cells(lngFirstRow + lngCopyRow, 5)
lngCopyRow = lngCopyRow + 1
End If
Next
lngCopyRow = lngCopyRow + lngFirstRow - 1
'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
Application.ScreenUpdating = True
End Sub

bye
malSchauen

Answer 5

Hi,

Noch eine Änderung für den Fall, dass alle Behandlungen in der Quelle der Kategorie2 zugehören. (B10 ist nicht leer, aber es wird auch nichts kopiert.) Dann dürfen nat. keine Kundendaten übertragen werden.

.
.
.
Next
If lngCopyRow > 0 Then ' wenn mindestens eine Zeile kopiert
lngCopyRow = lngCopyRow + lngFirstRow - 1
'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 If
End With
.
.
.

bye
malSchauen

Answer 6

Hi,

Ich habe oben stehenden Code in einer Testdatei getestet, seither erhalte ich selbst bei Makros - die bisher fehlerfrei funktionierten - folgende Fehlermeldung:

Laufzeitfehler 1004
Die Methode 'Rows' für das Objekt '_Global" ist fehlgeschlagen

Diese Makros enthalten ALLE folgende Codezeile, die als fehlerhaft angezeigt wird:
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

Und alle Dateien liegen im selben Ordner, Sicherungsdateien (andere Ordner) der letzten Tage funktionieren fehlerlos.

Ich stelle nun erstmal den letzen funktionierenden Zustand her ... melde mich aber auf jeden Fall nochmal - kann etwas dauern ;-)

Bisher erstmal vielen Dank für Eure Hilfe


Gruss - Petra

Answer 7

Hi,

Sollte der von mir abgeänderte Code aus AW14&15 dafür verantwortlich sein, dann bitte ich um Entschuldigung. Ich kann es mir aber nicht erklären, wie das zustande kommen kann. Evtl. kann mich jemand der hier noch mitliest und dieses Problem identifizieren kann über die Ursache/den Fehler in meinem Code aufklären.
Führt denn evtl. eine CodeZeile die mit "_" auf die folgende Zeile verlängert wird, beim Kopieren hier aus dem Forum zu einem solchen Problem? Ich habe es versucht das Problem hier nachzustellen, aber nach dem Einfügen läuft es klaglos, sodass ich den Fehler nicht nachvollziehen kann.

Petra: So Du Dich noch traust Code aus meinen Postings zu verwenden, so folgt hier, für den Fall dass es tatsächlich daran liegen sollte, nocheinmal das Makro ohne "Zeilenerweiterung" bei 'Behandlungsdaten:

Option Explicit

Const strPath = "C:\Eigene Dateien"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long
Dim lngCount 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 = 0

With Workbooks(Datei).Sheets(1)
For lngCount = 10 To lngLastRow
If .Range("A" & lngCount).Value = 1 Then
'Behandlungsdaten
.Range("B" & lngCount & ":H" & lngCount).Copy ActiveSheet.Cells(lngFirstRow + lngCopyRow, 5)
lngCopyRow = lngCopyRow + 1
End If
Next
If lngCopyRow > 0 Then ' wenn mindestens eine Zeile kopiert
lngCopyRow = lngCopyRow + lngFirstRow - 1
'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 If
End With
End If
Workbooks(Datei).Close
End If
Datei = Dir()
Loop
Application.ScreenUpdating = True

End Sub

bye
malSchauen

Answer 8

Hi malSchauen,

Petra: So Du Dich noch traust Code aus meinen Postings zu verwenden ...

Na klar ... immer her damit ;-)))

Mach Dir mal keinen "Kopf" ob es an dem Code lag .... das Risiko liegt ja wohl bei mir !! !!
Ich bin ja unheimnlich froh wenn ich hier Hilfe bekomme - alleine könnte ich das niemals lösen.

Aber was anderes: Dein Code funktioniert super gut ;-) ...
Vielen vielen Dank dafür

Gruss - Petra