Makro zum Importieren von Daten aus Excel-Dateien

Question

Hi liebes Forum,

ich brauche ein Makro zum Importieren von Daten aus verschiedenen Excel-Dateien in eine Excel-Datei. Ich habe schon versucht, mir verschiedene Threads zu diesbezüglichen Makros durchzulesen, aber ich komme einfach mit dem Code nicht richtig klar. Habe noch nie ein Makro programmiert und bin dementsprechend sehr neu in der Materie...

Ich würde mich sehr freuen, wenn jemand von Euch mir da weiterhelfen könnte. Falls jemand eine Seite kennt, auf der Makro-Befehle einfach erklärt werden, wäre das ebenfalls super. Würde nämlich auch gerne lernen, wie man sowas selbst machen kann.

Zu meinem Problem:

Ich habe ca. 100 Dateien, die fortlaufend nummeriert sind: KW_01_08.xls, KW_02_08.xls usw.

In diesen Dateien sind verschiedene Angaben nebeneinander geschrieben - und zwar nach Wochentagen sortiert.
Montag von B4:F60
Dienstag von H4:L60
Mittwoch N4:R60
Donnerstag T4:X60
Freitag Z4:AD60
Samstag AF4:AJ60
Sonntag AL4:AP60

Diese Bereiche sollen jetzt in einer neuen Daten alle untereinander gepackt werden.

Also jeweils die fünf Spalten des jeweiligen Wochentags als ein Block kopiert werden. Und der nächste Block dann drunter. So dass man am Ende alle Wochentage mit den fünf Spalten aus allen 100 Dateien untereinander hat.

Für das Ganze soll eine neue Excel-Datei erstellt werden.

Wäre super, wenn ihr mir hier weiterhelfen könntet. Das alles einzeln zu kopieren, ist extrem aufwändig, denke ich. Und ich möchte ja auch was über Makros lernen, damit ich sowas in Zukunft schneller wegfrühstücken kann ;)

Vielen Dank schon mal im Voraus! Sagt Bescheid, wenn noch Angaben fehlen!

Viele Grüße
Markus

Answer 1

Hallo Markus,

lade bitte eine Beispieldatei der Datei, die ausgelesen werden soll, z.B. bei http://www.file-upload.net/ ]hoch und teile uns den Link, den Du erhälst, hier mit. Denn Du hast ja bereits diese Dateien, wir müssten uns diese nachbauen.

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 2

Moin Oliver,

vielen Dank, dass Du Dich drum kümmerst. Sorry für die späte Antwort...war dann in der Mittagspause ;)

Hier ist der Link zur Datei:

http://www.file-upload.net/download-1949216/TV_KW01_08.xls.html

Grüße!

Answer 3

Hallo Markus,

nachfolgender Code öffnet Dir alle Dateien in einem bestimmten Verzeichnis und kopiert Dir die Daten in die aktive Datei. Da ich nicht weiß, ob Du die Daten komplett, also mit allen Formatierungen wie Rahmen und Hintergrundfarbe haben möchtest, habe ich mich erst mal dafür entschieden und das Makro so erstellt, dass alles, also auch die Formatierungen mitkopiert werden.

Kopiere das Makro 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 intDaten As Integer

Application.ScreenUpdating = False

Datei = Dir(strPath & "*.xls")
Do While Datei <> ""
If Right(Datei, 4) = ".xls" Then
Workbooks.Open strPath & Datei
For intDaten = 1 To 37 Step 6
lngFirstRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
lngLastRow = Workbooks(Datei).Sheets(1).Cells(65536, intDaten).End(xlUp).Row
Workbooks(Datei).Sheets("Tabelle1").Range(Cells(2, intDaten), Cells(lngLastRow, intDaten + 6)).Copy
ThisWorkbook.Sheets(1).Cells(lngFirstRow, 1).PasteSpecial
Next
Application.DisplayAlerts = False
Workbooks(Datei).Close
Application.DisplayAlerts = True
End If
Datei = Dir()
Loop
End Sub
Du musst in dem Makro in der Zeile

Const strPath = "C:\Eigene Dateien\"

noch den Pfad eintragen, in dem sich die auszulesenden Dateien befinden.

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

Moin Oliver,

vielen lieben Dank, dass Du Dir die Mühe gemacht hast!

Bin leider just in dem Moment, in dem Du das abgeschickt hast, aus dem Büro verschwunden. Werde es aber am Dienstag gleich ausprobieren und Feedback geben, ob es funktioniert hat. Ich bin aber sehr zuversichtlich ;)

Nochmal Danke und Dir ein schönes Wochenende!
Viele Grüße
Markus

Answer 5

Hallo Oliver,

ich hoffe, es macht nichts, wenn ich mich mit meiner Frage an diesen Eintrag "anhänge". Ich habe nämlich ein ähnliches Problem. Bisher lese ich bestimmte Inhalte von xls-files, die in einem bestimmten Ordner stehen, folgendermaßen aus:

Dim Datei$
Dim lngrow As Long
Datei = Dir(strPath & "\*.xls")

Do While Datei <> ""
On Error Resume Next
If Right(Datei, 4) = ".xls" And IsNumeric(Left(Datei, 2)) Then
lngrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(lngrow, 3) = Datei
ActiveSheet.Cells(lngrow, 6).FormulaLocal = "='" & strPath & "\[" & Datei & "]Testfälle'!$G$1"
ActiveSheet.Cells(lngrow, 7).FormulaLocal = "='" & strPath & "\[" & Datei & "]Testfälle'!$O$3"
ActiveSheet.Cells(lngrow, 8).FormulaLocal = "='" & strPath & "\[" & Datei & "]Testfälle'!$G$2"
End If
Datei = Dir()
Loop
On Error GoTo 0

Meine 2 Fragen hierzu:

1. Wie kann ich einen gesamten Ordner inklusive aller Unterordner durchsuchen (die Anzahl und Namen der Unterordner variieren mit der Zeit)?
2. Wie ziehe ich mir aus allen gefundenen xls-files den jeweils gleichen Bereich (z.B. A1:H200) - wenn möglich, ohne die Dateien alle hintereinander zu öffnen, sondern eher so, wie ich es bisher in o.a. Code mache?

Vielen Dank für die Hilfe, Gruß
Jojo

Answer 6

Hallo Jojo,

nachfolgend mal ein Makro, was alle Dateien in einem Verzeichnis und deren Unterordner ausliest, öffnet und den Bereich A1:H200 kopiert und in die erste freie Zelle in Spalte C schreibt. Ich habe mich dabei an Deinem alten Makro orientiert, kann aber nicht 100%ig versprechen, dass es auf Anhieb funktioniert, da ich keien Lust habe mir eine Datei zu erstellen, die ähnlch Deiner ist und bei der die Kriterien Deines Makros erfüllt sind.

Daher teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.

Option Explicit

Dim objFileSystemObject As Object
Dim objAnzDateien As Object
Dim objDurchläufe As Object
Dim objDateityp As Object
Dim lngrow As Long

Const strPath = "C:\Eigene Dateien\"

Sub Prüfung_start()
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objAnzDateien = objFileSystemObject.getfolder(strPath)
Call Prüfung
End Sub


Sub Prüfung()

For Each objDateityp In objAnzDateien.Files
If Right(objDateityp.Name, 4) = ".xls" And objDateityp.Name <> ThisWorkbook.Name _
And IsNumeric(Left(Datei, 2)) Then
lngrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row

GetObject (objDateityp)
With Workbooks(objDateityp.Name)
.Sheets(1).Range("A1:H200").Copy
ActiveSheet.Cells(lngrow, 3).PasteSpecial Paste:=xlPasteValues
.Close
End With
End If
Next

For Each objDurchläufe In objAnzDateien.subfolders
Set objAnzDateien = objDurchläufe
Call Prüfung
Next

Set objFileSystemObject = Nothing
Set objAnzDateien = Nothing

End SubDu musst in dem Modul in der Zeile

Const strPath = "C:\Eigene Dateien\"

den Pfad anpassen.

Was Du wolltest, also dass man die Dateien wie in Deinem Makro nicht öffnen muss, geht nicht. Du trägst mit Deinem Makro Formeln in die Zellen ein. Dazu muss man die Dateien nicht öffnen. Wenn Du aber ganze Bereiche kopieren möchtest, muss die Datei geöffnet werden.

Ich hoffe, es funktioniert. Wenn nicht, 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 7

Hallo Oliver,

vielen Dank! Ich hab' mich wohl zu undeutlich ausgedrückt. Mit "so, wie ich es bisher in o.a. Code mache" habe ich gemeint, dass ich die Verknüpfungen auf diese Dateien herstellen möchte. D.h. bspw. stehen in den Zeilen 1-200 die Verknüpfungen auf den Bereich A1:H200 der Datei_1 - in den Zeilen 201-400 stehen dann die Verknüpfungen auf den Bereich A1:H200 der Datei_2 usw.

Es ist sicher möglich, den Code
ActiveSheet.Cells(lngrow, 6).FormulaLocal = "='" & strPath & "\[" & Datei & "]Testfälle'!$G$1"
entsprechend fortzusetzen. Aber es erscheint mir nicht besonders gut - und vor allem nicht schnell - zu sein ...

Gibt es hierfür einen sinnvollen und vielleicht vba-technisch "schöneren/sauberen" Weg?

Gruß
Jojo

Answer 8

Hallo Jojo,

nachfolgendes Makro sollte das machen was Du Dir vorgestellt hast, sofern ich es diemal verstanden habe, was genau Du möchtest?

!!! Achtung, ich habe den Code jetzt nicht getestet. Daher teste den erst mal in einer Kopie Deiner Datei !!!

Option Explicit

Dim objFileSystemObject As Object
Dim objAnzDateien As Object
Dim objDurchläufe As Object
Dim objDateityp As Object
Dim lngrow As Long
Dim intRowFormula As Integer
Dim intColumnFormual As Integer
Dim strColumnFormula As String

Const strPath = "C:\Eigene Dateien\"

Sub Prüfung_start()
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "Vorgang läuft..."
End With

Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objAnzDateien = objFileSystemObject.getfolder(strPath)
Call Prüfung

ERRORHANDLER:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.Calculate
.StatusBar = ""
End With
End Sub

Sub Prüfung()
For Each objDateityp In objAnzDateien.Files
If Right(objDateityp.Name, 4) = ".xls" And objDateityp.Name <> ThisWorkbook.Name _
And IsNumeric(Left(Datei, 2)) Then
For intRowFormula = 1 To 200
lngrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
For intColumnFormual = 1 To 8
strColumnFormula = Application.Substitute(Cells(1, intColumnFormual).Address(0, 0), 1, "")
ActiveSheet.Cells(lngrow, intColumnFormual).FormulaLocal = _
"='" & strPath & "\[" & objDateityp.Name & "]Testfälle'!$" & strColumnFormula _
& "$" & intRowFormula
Next
Next
End If
Next

For Each objDurchläufe In objAnzDateien.subfolders
Set objAnzDateien = objDurchläufe
Call Prüfung
Next

Set objFileSystemObject = Nothing
Set objAnzDateien = Nothing

End Sub

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

Moin Oliver,

habe das Makro heute ausprobiert und es hat super funktioniert! Nochmal vielen Dank an dieser Stelle!

Bringt es Dir was, wenn ich mich hier ordentlich anmelde und auf diesen Schriftzug klicke? (--> Diese Antwort hat mein Problem gelöst)
Oder reicht Dir das quasi-persönliche Feedback aus?

Vielen Dank und viele Grüße
Markus

Answer 10

Hallo Markus,

gerne geschehen. Danke auch für die Rückmeldung.

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]