Anzeige
Archiv - Navigation
988to992
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
988to992
988to992
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Kopieren von vielen Dateien in viele Dateien

Kopieren von vielen Dateien in viele Dateien
06.07.2008 00:07:03
vielen
Hallo Leute, bin neu in dem Forum, aber vielleicht kann mir jemand helfen.
Ich habe in 2 Verzeichnissen jeweils ca. 1500 Dateien in vielen Unterverzeichnissen.
Jetzt muss ich aus den Dateien des 1. Verzeichnises bestimmte Zellen auslesen und in die Dateien des 2. Verzeichnisses kopieren. Die Dateien des 2. Verzeichnisses unterscheiden sich durch den Zusatz "über 100" von den Dateien des 2. Verzeichnisses.
Ich kann Dateien des 1. Verzeichnisses auslesen und händeln - wie ich aber die Dateien aus dem 2. Verzeichnis einlesen und daraus bestimmte Zellen in die Dateien des 1. Verzeichnisses kopieren soll - habe ich bisher nicht herausgefunden.
Hier mein Ansatz:

Sub Makro_kopiere_Zellen_100()
Dim Mappe As Variant
Dim Mappe1 As Variant
Const LW = "D:\"
Const Pfad = "D:\users\caonix\Postwurf spezial\"
Const Pfad1 = "D:\users\caonix über100\Postwurf spezial\"
Const Verzeichnis = "D:\users\caonix\Postwurf spezial\"
Const Verzeichnis1 = "D:\users\caonix über100\Postwurf spezial\"
On Error GoTo Fehler
ChDrive LW
ChDir Pfad
'Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = Verzeichnis
.Filename = "*.xls"
.SearchSubFolders = True
If .Execute() > 0 Then
For Each Mappe In .FoundFiles
'            Debug.Print Mappe
Workbooks.Open Mappe
Sheets("PWurf Spezial").Select
'   Mache den Pfad1 auf
'   Hole die 1. Datei aus dem 1. Unterverzeichnis (Mappe1)
'   Kopiere aus dem Sheet (PWurf) I19 bis I97
'   Gehe zum Workbook Mappe
'   Einfügen der Daten in C19 bis C97
'   Schließe Mappe1 ohne Speichern
ActiveWorkbook.Close SaveChanges:=True
Next Mappe
End If
End With
Exit Sub
Fehler: MsgBox "O je, O je - ein Fehler"
Application.ScreenUpdating = True
End Sub


2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kopieren von vielen Dateien in viele Dateien
06.07.2008 13:09:00
vielen
Hi Steho,
probier mal diesen Code.

Option Explicit
Sub Makro_kopiere_Zellen_100()
Dim lngMappe As Long, AWF As WorksheetFunction
Const LW = "D"
Const Pfad = "D:\users\caonix\Postwurf spezial\"
Const Pfad1 = "D:\users\caonix über100\Postwurf spezial\"
Set AWF = Application.WorksheetFunction
On Error GoTo Fehler
ChDrive LW
ChDir Pfad
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = Pfad
.Filename = "*.xls"
.SearchSubFolders = True
If .Execute() > 0 Then
For Each lngMappe In .FoundFiles
Workbooks.Open .FoundFiles(lngMappe)
Sheets("PWurf Spezial").Range("I19:I97").Copy
ActiveWorkbook.Close SaveChanges:=False
Workbooks.Open AWF.Substitute(.FoundFiles(lngMappe), Pfad, Pfad1)
Sheets("PWurf Spezial").Range("C19:C97").Select
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next lngMappe
End If
End With
Fehler:
If Err.Number  0 Then MsgBox "O je, O je - ein Fehler"
Application.ScreenUpdating = True
End Sub


Gruß
Reinhard

Anzeige
AW: Kopieren von vielen Dateien in viele Dateien
06.07.2008 16:02:00
vielen
Hallo Reinhard,
vielen Dank für die schnelle Antwort.
Leider steigt das Makro nach Einlesen der Dateien bei Workbooks.Open aus und verzweigt zur Fehlermeldung. Warum? Hat das mit der Dimensionierung zu tun? Nach der Fehlermeldung habe ich sie auf Variant gesetzt. Dimensionierung als Object führt aber zum gleichen Ergebnis.
Option Explicit
'

Sub Makro_kopiere_Zellen_100()
'Dim lngMappe As Long, AWF As WorksheetFunction
'Fehlermeldung "Steuervarialbe für For Each muss vom Typ Variant oder Objekt sein"
Dim lngMappe As Variant, AWF As WorksheetFunction
Const LW = "D"
Const Pfad = "D:\users\caonix\Postwurf spezial\"
Const Pfad1 = "D:\users\caonix über100\Postwurf spezial\"
Set AWF = Application.WorksheetFunction
On Error GoTo Fehler
ChDrive LW
ChDir Pfad
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = Pfad
.Filename = "*.xls"
.SearchSubFolders = True
If .Execute() > 0 Then
For Each lngMappe In .FoundFiles
Workbooks.Open .FoundFiles(lngMappe)
   ' ab hier Sprung zu Fehler
Sheets("PWurf Spezial").Range("I19:I97").Copy
ActiveWorkbook.Close SaveChanges:=False
Workbooks.Open AWF.Substitute(.FoundFiles(lngMappe), Pfad, Pfad1)
Sheets("PWurf Spezial").Range("C19:C97").Select
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next lngMappe
End If
End With
Fehler:
If Err.Number  0 Then MsgBox "O je, O je - ein Fehler"
Application.ScreenUpdating = True
End Sub


Anzeige

157 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige