Supportnet / Forum / Tabellenkalkulation

Servus, Wie Ihr sehen könnt habe ich unten ein Makro, in dem das Programm in ein angegebenen Ordner geht und alle vorhandenen Exceldateien nacheinander öffnet und etwas in eine Datei kopiert. Das funktioniert auch. Nun meine Frage!! Da ich über 400 Exceldatein habe und nur bestimmte brauche, kann man das Programm so umschreiben, dass man den die gebrauchten Dateinamen in die Spalte A reinschreibt und das Programm nur die öffnet, die in Spalte A in einer Datei mit dem Namen Quelle stehen. Vielen Dank auf jeden Fall. Glaube auf euch kann man sich verlassen. Option Explicit Sub BPübersicht() Dim Mappen As Integer Dim zeile As Integer Dim Letztezeile As Integer Application.DisplayAlerts = False With Application.FileSearch .NewSearch .LookIn = Range("B1") .SearchSubFolders = False .Filename = "*.xls" If .Execute() > 0 Then For Mappen = 1 To .FoundFiles.Count Workbooks.Open Filename:=.FoundFiles(Mappen) ActiveWindow.ScrollRow = 1 Sheets("Tabelle").Select Range("b6").Select Application.CutCopyMode = False Selection.Copy Windows("Neues.xls").Activate Sheets("Gesamt").Select zeile = Range("A65536").End(xlUp).Row Range("A" & zeile + 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Workbooks(2).Activate ActiveWindow.ScrollRow = 1 Sheets("Tabelle").Select Range("C6").Select Application.CutCopyMode = False Selection.Copy Windows("Neues.xls").Activate Sheets("Gesamt").Select zeile = Range("A65536").End(xlUp).Row Range("B" & zeile).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Workbooks(2).Activate ActiveWindow.ScrollRow = 1 Sheets("Tabelle").Select Range("E65").Select Application.CutCopyMode = False Selection.Copy Windows("Neues.xls").Activate Sheets("Gesamt").Select zeile = Range("A65536").End(xlUp).Row Range("C" & zeile).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Workbooks(2).Activate ActiveWindow.ScrollRow = 1 Sheets("Tabelle").Select Range("P38").Select Application.CutCopyMode = False Selection.Copy Windows("Neues.xls").Activate Sheets("Gesamt").Select zeile = Range("A65536").End(xlUp).Row Range("D" & zeile).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Workbooks(2).Close Next Mappen End If End With End Sub

Hallo Fragenkatalog,

leider kann ich dein Aufbau nicht genau nachvollziehen, da in deinem Code einiges unklar ist.
Also ich vermute mal du hast eine Datei "Neues" mit einem Blatt "Gesamt" auf das du aus bestimmte anderen Datei etwas kopieren möchtest.
Folgender Code sollte das machen:

Option Explicit

Sub BPübersicht()
Application.ScreenUpdating = False
Dim i As Integer, arr() As String, Zeile As Integer, Datei As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
ChDir Workbooks("Neues").Sheets("Daten").Range("B1")
Datei = Workbooks("Neues").Sheets("Daten").Cells(i, 1)
Workbooks.Open Filename:=Datei
ReDim arr(4)
arr(1) = Sheets("Tabelle").Range("B6")
arr(2) = Sheets("Tabelle").Range("C6")
arr(3) = Sheets("Tabelle").Range("E65")
arr(4) = Sheets("Tabelle").Range("P38")
Workbooks(Datei).Close
Zeile = Sheets("Gesamt").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheets("Gesamt").Cells(Zeile, 1) = arr(1)
Sheets("Gesamt").Cells(Zeile + 1, 1) = arr(2)
Sheets("Gesamt").Cells(Zeile + 2, 1) = arr(3)
Sheets("Gesamt").Cells(Zeile + 3, 1) = arr(4)
Next i
Application.ScreenUpdating = True
End Sub

In der Datei "Neues" muss sich ein Blatt mit dem Namen "Daten" befinden. Auf diesem trägst du in Spalte A die Dateinamen die die zu kopierenden Daten enthalten ein. In B1 steht der Pfad zu den Dateien.

Am besten du siehst es dir mal an und meldest dich bei Fragen nochmal.

MfG

JöKe

Servus,

du bist wie immer genial.

es läuft bis jetzt, aber es läuft nicht ganz durch..
es stoppt dann bei Workbooks.Open Filename:=Datei
ein Laufzeitfehler 1004.

Hoffe du kannst mir diesmal auch helfen.
Außerdem geht es auch, dass ich in A1 eine Überschrift schreibe und er ab A2 erst die datei rausschreibt.. was passiert wenn mal eine Leere zeile dazwischen ist??

Danke


Option Explicit

Sub Übersicht()
Application.ScreenUpdating = False
Dim i As Integer, arr() As String, Zeile As Integer, Datei As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
ChDir Workbooks("Neues.xls").Sheets("Daten").Range("C1")
Datei = Workbooks("Neues.xls").Sheets("Daten").Cells(i, 1)
Workbooks.Open Filename:=Datei
ReDim arr(4)
arr(1) = Sheets("Input Sheet").Range("B6")
arr(2) = Sheets("Input Sheet").Range("C6")
arr(3) = Sheets("Exec. Summary").Range("E65")
Workbooks(Datei).Close
Zeile = Sheets("Gesamt").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheets("Gesamt").Cells(Zeile, 1) = arr(1)
Sheets("Gesamt").Cells(Zeile + 1, 1) = arr(2)
Sheets("Gesamt").Cells(Zeile + 2, 1) = arr(3)
Sheets("Gesamt").Cells(Zeile + 3, 1) = arr(4)
Next i
Application.ScreenUpdating = True
End Sub

Hallo Fragenkatalog,

der Laufzeitfehler kann daher kommen das in deiner Liste ein Name falsch geschrieben ist oder dem entsprechenden Ordner nicht vorkommt.

Um in A2 zu beginnen ändere die Zeile:

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

in:

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

Um eine Fehlermeldung bei leeren Zellen abzufangen, füge nach :

Sub BPübersicht()
Application.ScreenUpdating = False

On Error Resume Next ein.


Gruß

Danke ist mal kurz gelaufen also müsste es funktionieren.

Wollte dich noch kurz fragen, ob ich auch in der Datentabelle in einer bestimmten Zeile z.b. (D7) festlegen kann welche Zellen das Makro aus der Quelldatei kopieren soll?

Danke vielmals.

Hallo nochmal,

haben vorhin deinen Code nicht genau beachtet.

Hier ReDim arr(4) kannst du die 4 in 3 ändern. Die Zahl in der () gibt an wieviele Daten in das Array gelesen werden.

Da du nur drei Daten einliest, benötigst du auch nur drei Zielzeilen. Somit kann diese Zeile:

Sheets("Gesamt").Cells(Zeile + 3, 1) = arr(4) ebenfalls gelöscht werden.

Gruß

in eine Zelle (D7) geht nicht. Aber ab D7 geht.

Die Zeile:

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

in

For i = 7 To Cells(Rows.Count, 4).End(xlUp).Row

abändern. Und die Zeile:

Datei = Workbooks("Neues.xls").Sheets("Daten").Cells(i, 1)

in:

Datei = Workbooks("Neues.xls").Sheets("Daten").Cells(i, 4)

abändern.


Zum besseren verständnis:
Die Zahlen in () hinter Cells geben die "Zellenkoordinaten" an. Der erste Wert ist die Zeile und der zweite Wert die Spalte. Z.B. ist A1 = Cells(1, 1), D7 ist demnach Cells(7, 4)
usw.

Gruß

heute hab ichs glaub ich nicht mit dem lesen.

wenn die Namen der Dateien in einer Zeile stehen sollen sehen oben genannte Zeile so aus:

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

For i = 4 To Cells(7, Columns.Count).End(xlToLeft).Column

Datei = Workbooks("Neues.xls").Sheets("Daten").Cells(i, 1)

Datei = Workbooks("Neues").Sheets("Daten").Cells(7, i)


Gruß

Servus Jöke,

jetzt habe ich aber total den Überblick verloren. Hatte leider in der letzten Zeit zu viel zu tun, dass ich erst jetzt reinschauen kann.

Leider bin ich bisschen verwirt, deshalb muss ich dich noch einmal Fragen.
Wie muss ich denn, das Makro ausschauen, wenn ich die Namen der Dateien, die das Makro öffnen soll ab A4 nach stehen und das zweite in A5 dann steht usw.

Außerdem wollte ich wissen, ob ich das Tabellenblatt aus dem die Informationen rauskopiert werden sollen (aus der zu öffnenden Datei) und auch die Zelle die kopiert werden soll in einer Zelle bestimmen kann, so dass ich es immer ändern kann?

Danke..

Hallo Fragenkatalog,

leider habe ich zwischenzeitlich meine Testdatei für dein Problem gelöscht.
Aber Nachfolgende Code sollte das von dir gewünschte machen:

Option Explicit

Sub Übersicht()
Application.ScreenUpdating = False
On Error Resume Next
Dim i As Integer, arr() As String, Zeile As Integer, Datei As String
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
ChDir Workbooks("Neues.xls").Sheets("Daten").Range("C1")
Datei = Workbooks("Neues.xls").Sheets("Daten").Cells(i, 1)
Workbooks.Open Filename:=Datei
ReDim arr(3)
arr(1) = Sheets("Input Sheet").Range("B6")
arr(2) = Sheets("Input Sheet").Range("C6")
arr(3) = Sheets("Exec. Summary").Range("E65")
Workbooks(Datei).Close
Zeile = Sheets("Gesamt").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheets("Gesamt").Cells(Zeile, 1) = arr(1)
Sheets("Gesamt").Cells(Zeile + 1, 1) = arr(2)
Sheets("Gesamt").Cells(Zeile + 2, 1) = arr(3)
Next i
Application.ScreenUpdating = True
End Sub

Die Namen der Dateien die geöffnet werden sollen stehen nun ab A4 abwärts auf dem Blatt Daten.
Habe ich das richjtig gesehen, dass du nur noch 3 Zellen kopieren möchtest oder hast du versehndlich eine Zeile im Ursprungscode gelöscht?

MfG

JöKe

Ja danke dir noch einmal.. ja das hast du schon richtig gesehen.
Das kann ich ja notfalls nochmal selber umstellen.
Vielen Danke

• Datensicherung
• Fensterschließen mit Makro
• Programm von einem Rechner auf anderen übertragen
• Alte Daten auf CD weg??
• Wie lasse ich bestimmte Dateien beim Start automatisch öffnen?