Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Makro anpassen!!!!????





Frage

Hi, Dieses Makro geht in den Ordner und öffenet alle Exel Dateien die sich da befinden und kopiert 2 Zellen und macht für ca. 300 Dateien. Aber ab und zu will ich nicht alle 300 Dateien zusammenfassen. gibt es eine Möglichkeit, dass ich im Tabellenblatt "Daten" In Spalte A ab zeile 3 die Dateinamen schreibe, die er öffnen soll. Und das Makro läuft nur über die Dateien? Wäre super wenn sich ein Experte findet der mir da hilft!! Sub Zusammenfassung() Dim Mappen As Integer Dim zeile As Integer Dim Letztezeile As Integer On Error Resume Next Application.AskToUpdateLinks = False Application.DisplayAlerts = False Sheets("Daten").Select With Application.FileSearch .NewSearch .LookIn = Range("D1") .SearchSubFolders = False .Filename = "*.xls" If .Execute() > 0 Then For Mappen = 1 To .FoundFiles.Count Workbooks.Open Filename:=.FoundFiles(Mappen) Application.Calculate ActiveWindow.ScrollRow = 1 Sheets("Tabelle1").Select Range("B6").Select Application.CutCopyMode = False Selection.Copy Windows("Zusammen.xls").Activate Sheets("Roll-Up").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("Tabelle2").Select Range("C6").Select Application.CutCopyMode = False Selection.Copy Windows("Zusammen.xls").Activate Sheets("Roll-Up").Select zeile = Range("A65536").End(xlUp).Row Range("B" & zeile).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Workbooks(2).Close Activepage.Save Next Mappen End If End With End Sub Danke

Antwort 1 von fürLau

Hallo

Nachdem Du mit dem speziell nach Deinen Angaben, von mir geschrieben Code nich klargekommen bist, hier also Dein "angepasstes Makro":
Option Explicit

Sub Zusammenfassung()
Dim Mappen As Integer
Dim zeile As Integer
Dim Letztezeile As Long ´ geändert
Dim c As Range  ´ neu dazu gekommen
On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Sheets("Daten").Select
With Application.FileSearch
.NewSearch
.LookIn = Range("D1")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
Letzezeile = Range("a65535").End(xlUp).Row ´ neu dazu gekommen
For Mappen = 1 To .FoundFiles.Count
With Range("A3:" & CStr(Letztezeile)) ´ neu dazu gekommen
c = .Find(.foundfile(Mappen), LookIn:=xlValues) ´ neu dazu gekommen
End With ´neu dazu gekommen
If c = Nothing Then GoTo naechster ´ neu dazu gekommen
Workbooks.Open Filename:=.FoundFiles(Mappen)
Application.Calculate

ActiveWindow.ScrollRow = 1
Sheets("Tabelle1").Select
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Zusammen.xls").Activate
Sheets("Roll-Up").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("Tabelle2").Select
Range("C6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Zusammen.xls").Activate
Sheets("Roll-Up").Select
zeile = Range("A65536").End(xlUp).Row
Range("B" & zeile).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Workbooks(2).Close
Activepage.Save
naechster: ´neu dazu gekommen
Next Mappen
End If
End With
End Sub



Gruß

Antwort 2 von nighty

hi all

auf die schnelle

gruss nighty

Sub Zusammenfassung()
Dim Mappen As Integer
Dim zeile As Integer
Dim Letztezeile As Integer
Dim zelle As Range
On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Sheets("Daten").Select
Set Mappennamen = Range("A3:A5")
For Each zelle In Mappennamen
Workbooks.Open Filename:="C:\Temp\" & zelle & ".xls"
Application.Calculate
ActiveWindow.ScrollRow = 1
Sheets("Tabelle1").Select
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Zusammen.xls").Activate
Sheets("Roll-Up").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("Tabelle2").Select
Range("C6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Zusammen.xls").Activate
Sheets("Roll-Up").Select
zeile = Range("A65536").End(xlUp).Row
Range("B" & zeile).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks(2).Close
Activepage.Save
Next zelle
End Sub

Antwort 3 von fürLau

Antwort 4 von Fragenkatalog

Hallo für Lau,
bin grad drüber deine Lösung auszuprobieren. aber hab da irgend ein Fehler gefunden. Sonst finde ich es genieal, danke für die Hilfe aber ich kann es nicht laufen lassen. Beim Start hat er einen Fehler bei Nothing then goto..


was kann das sein??

Danke

Antwort 5 von CaroS

Hallo fürLau,

finde folgende Stelle in Deinem Code (AW1) verdächtig:

With Range("A3:" & CStr(Letztezeile)) ´ neu dazu gekommen
c = .Find(.foundfile(Mappen), LookIn:=xlValues) ´ neu dazu gekommen
End With ´neu dazu gekommen
If c = Nothing Then GoTo naechster ´ neu dazu gekommen

Tippe auf
With Range("A3:A" & CStr(Letztezeile)) ´ neu dazu gekommen

Vielleicht verschwindet dann auch der Fehler in AW4.

Gruß,
CaroS

Antwort 6 von Fragenkatalog

Hallo Caros und alle anderen,

also habe es umgetauscht aber der markiert mir wenn ich das Makro laufen lassen will immer noch das Nothing
und dann steht da ein Box mit :"Fehler beim Kompilieren:
Unzulässige Verwendung eines Objekts.

Kann mir da jemand helfen.


Sub Zusammenfassung()
Dim Mappen As Integer
Dim Zeile As Integer
Dim Letztezeile As Long ´ geändert
Dim c As Range ´ neu dazu gekommen
On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Sheets("Daten").Select
With Application.FileSearch
.NewSearch
.LookIn = Range("D1")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
Letztezeile = Range("a65535").End(xlUp).Row ´ neu dazu gekommen
For Mappen = 1 To .FoundFiles.Count
With Range("A3:A" & CStr(Letztezeile)) ´ neu dazu gekommen
c = .Find(.foundfile(Mappen), LookIn:=xlValues) ´ neu dazu gekommen
End With ´neu dazu gekommen
If c = Nothing Then GoTo naechster ´ neu dazu gekommen
Workbooks.Open Filename:=.FoundFiles(Mappen)
Application.Calculate







Workbooks(2).Close
Activepage.Save
naechster: ´neu dazu gekommen
Next Mappen
End If
End With
End Sub

Antwort 7 von CaroS

Hallo Fragenkatalog, hallo fürLau,

vermute, dass es an einem fehlenden kleinen s liegt (2 Zeilen oberhalb von If c = Nothing):

c = .Find(.foundfile(Mappen), LookIn:=xlValues) ´ neu dazu gekommen

c = .Find(.foundfiles(Mappen), LookIn:=xlValues) ´ neu dazu gekommen

Im allgemeinen fummle ich nicht so gern in fremdem Code rum, aber wenn´s (ihn) schön macht ...

Gruß,
CaroS

Antwort 8 von fürLau

Hallo CaroS, Fragenkatalog
@CaroS, das war nur einer der Fehler (-:
Neuer Versuch, vielleicht klappt´s so:

Option Explicit
Sub Zusammenfassung()
Dim Mappen As Integer
Dim zeile As Integer
Dim Letztezeile As Long ´ geändert
Dim c As Range ´ neu dazu gekommen
Dim Name As String ´ neu dazu gekommen
On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Sheets("Daten").Select
With Application.FileSearch
.NewSearch
.LookIn = Range("D1")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
Letztezeile = Range("A65535").End(xlUp).Row ´ neu dazu gekommen
For Mappen = 1 To .FoundFiles.Count
With Range("A3:A" & CStr(Letztezeile)) ´ neu dazu gekommen

Name = Mid(Application.FileSearch.FoundFiles(Mappen), _
Len(Range("D1").Value) + 1, _
InStr(Application.FileSearch.FoundFiles(Mappen), _
".xls") - Len(Range("D1")) - 1) ´ neu dazu gekommen

Set c = .Find(Name, LookIn:=xlValues)  ´ neu dazu gekommen
End With ´ neu dazu gekommen

If c Is Nothing Then GoTo naechster ´ neu dazu gekommen und geändert
Workbooks.Open Filename:=.FoundFiles(Mappen)
Application.Calculate
ActiveWindow.ScrollRow = 1
Sheets("Tabelle1").Select
Range("B6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Zusammen.xls").Activate
Sheets("Roll-Up").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("Tabelle2").Select
Range("C6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Zusammen.xls").Activate
Sheets("Roll-Up").Select
zeile = Range("A65536").End(xlUp).Row
Range("B" & zeile).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Workbooks(2).Close
ActiveSheet.Save
naechster: ´neu dazu gekommen

Next Mappen
End If
End With
End Sub


Gruß

Antwort 9 von Fragenkatalog

Hallo an alle, die sich hier in die Sache mit eingeschalten haben.

ich bewundere euch ja schon, dass Ihr überhaupt da so gut auskennt.
Ich habe jetzt das neue Makro einkopiert und dann gestartet.
Habe davor mit einem anderen Makro die Dateinamen von dem Pfad in die Spalte a3bis a... kopiert.
Aber wenn ich das Makro dann starte und geht es aber nicht.

Es läuft durch und

geht bis zu fogenden Zeile:

Option Explicit
Sub Zusammenfassung()
Dim Mappen As Integer
Dim zeile As Integer
Dim Letztezeile As Long ´ geändert
Dim c As Range ´ neu dazu gekommen
Dim Name As String ´ neu dazu gekommen
On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Sheets("Daten").Select
With Application.FileSearch
.NewSearch
.LookIn = Range("D1")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
Letztezeile = Range("A65535").End(xlUp).Row ´ neu dazu gekommen
For Mappen = 1 To .FoundFiles.Count
With Range("A3:A" & CStr(Letztezeile)) ´ neu dazu gekommen

Name = Mid(Application.FileSearch.FoundFiles(Mappen), _
Len(Range("D1").Value) + 1, _
InStr(Application.FileSearch.FoundFiles(Mappen), _
".xls") - Len(Range("D1")) - 1) ´ neu dazu gekommen

Set c = .Find(Name, LookIn:=xlValues) ´ neu dazu gekommen
End With ´ neu dazu gekommen

If c Is Nothing Then GoTo naechster ´ neu dazu gekommen und geändert

dann spingt er weiter zu

naechster: ´neu dazu gekommen

Next Mappen
End If
End With
End Sub

wieso läuft das makro nicht.. wieso geht es nicht in meine Datein und kopiert die Zellen??

Woran könnte es liegen??
Ich habe in eine Blatt Daten den Pfad und auch die Dateinamen stehen...

Woran kann es noch liegen?

Gruß

Antwort 10 von fürLau

Hallo nochmal

Ich bin davon ausgegangen - wie weiter oben beschrieben - daß in der Zelle [D1] der Pfad zu den Dateien (z.B. "c:\Eigene Dateien\ ")steht. Weiterhin davon daß im Bereich A3:Ax die Dateinamen und zwar ohne den suffix ( .xls )stehen.

Damit hat es zumindest bei mir dann funktioniert.

Gruß

Antwort 11 von Fragenkatalog

Hallo,

wäre es ein großes Problem wenn ich die Dateinamen mit xls stehen lassen würde??

oder reicht es wenn ich hier


InStr(Application.FileSearch.FoundFiles(Mappen), _
".xls") - Len(Range("D1")) - 1) ´ neu dazu gekommen

das .xls weg mache.

Danke

Antwort 12 von fürLau

hi,

Nein das reicht nicht, ersetze das statement:
Zitat:
Name = Mid(Application.FileSearch.FoundFiles(Mappen), _
Len(Range("D1").Value) + 1, _
InStr(Application.FileSearch.FoundFiles(Mappen), _
".xls") - Len(Range("D1")) - 1) ´ neu dazu gekommen

durch:

Name = Right(Application.FileSearch.FoundFiles(Mappen), _
Len(Application.FileSearch.FoundFiles(Mappen)) - Len(Range("D1").Value))


dann sollte es klappen

Gruß

Antwort 13 von Fragenkatalog

Hallo,

Danke nochmal für die ganzen Makros.
Bei mir ist das Problem, dass es nicht läuft immernoch da.
Habe das Macro auch mit F8 durchlaufen lassen und es öffnet keine Dateien, springt davor auf naechter.

kann es vielleicht daran liegen, wie ich meine Dateien in der Zeile A reinschreibe.

habe auch dafür ein Makro..

Schaut aus wie folgt und schreibt die Dateinamen so wie ich die im Explorer sehe auch in die Spalte A rein.

Sub DateiName()
Dim DatNam As String
Dim DatPfad As String
Dim zeile As Long
Sheets("Daten").Activate
DatPfad = Range("D1")
Range("A3:A65536").Clear
zeile = 3
DatNam = Dir$(DatPfad & "\*.xls")
Do While Len(DatNam) > 0
Cells(zeile, 1).Value = DatNam
zeile = zeile + 1
DatNam = Dir$()
Loop
End Sub


Danke.

Antwort 14 von fürLau

Hallo

Kann ich hier nicht nachvollziehen, aber nimm ´mal das
On Error Resume Next
raus (remark davor schreiben) und schau was dann passiert

Gruß

Antwort 15 von nighty

hi all

fehlervermeidung ist oftmals besser alls fehler abzufangen

sollten die fehler bekannt sein ,könnte mann den fehlercoder err in einer zelle darstellen bzw ermitteln und so in der fehlerroutine anhand einer prüfung (z.b. if err=DeinFehlerCode then) entsprechend reagieren und dann ein resume next angibt um fuer andere unbekannte fehler noch weiter reagieren zu können

gruss nighty

Antwort 16 von CaroS

Hi all,

zu AW12 und AW13 (läuft immer noch nicht).

Irgendwas scheint mit der Variablen Name (zuletzt:
Name = Right(Application.FileSearch.FoundFiles(Mappen), _
Len(Application.FileSearch.FoundFiles(Mappen)) - Len(Range("D1").Value)) )
nicht zu stimmen. Fragenkatalog, wenn Du sowieso schon im Debug-Modus mit F8 arbeitest, dann schalte doch mal für die Variable Name die Überwachung ein (im Code Rechtsklick auf Name -- Überwachung) und beobachte den Wert. Und für c ebenso.

(Vielleicht muss man auch noch Application.FileSearch.FoundFiles.Count und Letztezeile überprüfen, dass da wenigstens was halbwegs sinnvolles drinsteht?)

Wenn, wie angenommen, Name nicht in Ordnung ist, wird/bleibt c = .Find(Name, LookIn:=xlValues) gleich Nothing und If c Is Nothing Then GoTo naechster springt zwangsläufig zur Marke naechster:. Das scheint der Stand zu sein.

Lässt sich hier was bestätigen/wiederlegen/ausschließen?

Leider bin ich mir nicht sicher, dass ich den aktuellen Stand komplett und fehlerfrei einschließlich der gesamten Beispielsituation in eine Mappe kriege und dann wirklich am "Original" herumexperimentiere. Etwas anderes hätte aber überhaupt keinen Zweck, da würde nur noch jemand an allen anderen und dem wahren Problem vorbeireden.

Also, wenn der Fehler weiter besteht und Du Dir was davon versprichst, dann veröffentliche doch noch mal den kompletten aktuellen Stand und die wichtigsten Zusatzinformationen. Sheets("Daten"), D1 enthält den Namen des Verzeichnisses, um das es geht, A3:Axx enthält die Dateinamen in der Form Pfad_wie_in_D1\Beliebiger_Name.xls - richtig? Muss man sonst noch was wissen?

Gruß,
CaroS

Antwort 17 von Fragenkatalog

Hallo an alle,
erstmal freut es mich sehr dass es so viele gibt, die sich hier für das Problem interessieren und auch mitwirken um es zu lösen.

doch ich denke ich habe den Fehler gefunden.
Der Fehler besteht, nur darin dass ich in meinem Pfad also Zelle D1 folgendes reinschreibe.

C:\ordner1\ordner2\unterordner.

anscheinend muss ich damit das Makro läuft ein weiteres "\" hinter den Pfad eintippen. Sonst findet das Makro die Dateien nicht.
Kleines Zeichen großer Fehler. kamm man eigentlich das nicht im Makro umschreiben, damit es auch reicht wenn ich den Pfad aus dem Explorer rauskopiere.
Also ohen "\" am ende?

Danke hier noch einmal des Programm.

Option Explicit
Sub Zusammenfassung()
Dim Mappen As Integer
Dim zeile As Integer
Dim Letztezeile As Long ´geändert
Dim c As Range ´neu dazu gekommen
Dim Name As String ´neu dazu gekommen
On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Sheets("Daten").Select
With Application.FileSearch
.NewSearch
.LookIn = Range("D1")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
Letztezeile = Range("A65535").End(xlUp).Row ´neu dazu gekommen
For Mappen = 1 To .FoundFiles.Count
With Range("A3:A" & CStr(Letztezeile)) ´neu dazu gekommen

Name = Right(Application.FileSearch.FoundFiles(Mappen), _
Len(Application.FileSearch.FoundFiles(Mappen)) - Len(Range("D1").Value))

Set c = .Find(Name, LookIn:=xlValues) ´neu dazu gekommen
End With ´neu dazu gekommen

If c Is Nothing Then GoTo naechster ´neu dazu gekommen und geändert
Workbooks.Open Filename:=.FoundFiles(Mappen)
Application.Calculate

Danke

Antwort 18 von CaroS

Hi,

Du müsstest etwa in der Mitte .LookIn = Range("D1") durch
.LookIn = Range("D1") & "\" ersetzen, d. h. & "\" hinten dranhängen. Und testen, ob´s funktioniert. Notfalls auch mit F8 und Überwachung der Variablen.

Gruß,
CaroS

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: