AW: kopieren von Zeilen aus Datei in mehrere Datei
15.07.2014 15:03:38
Zeilen
Hallo Guebla,
nachfolgend Makros zur Bearbeitung einer Liste von Dateien.
Verbundene Zellen in den Zieldateien könnten aber Probleme bereiten.
Kopiere zum Testen ein paar Zieldateien in ein Testverzeichnis.
Im Makro musst du den Namen der Vater-/Masterdatei und die Zeilennummern der zu kopierenden Zeilen anpassen.
Gruß
Franz
'Code in einem allgemeinen Modul
Option Explicit
'Quelle: http://www. _
herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: fcs 2010-08-07
Public lCount As Long, arrFiles() As String
Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, _
Optional FolderName As Boolean = False)
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter Datei,* als Platzhalter verwenden,Optional leer ist alle
'3.Parameter mit Unterordner = True, Optional False ist ohne
'4.Parameter kompl. Pfad ausgeben = True, Optional nur Dateiname = False
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - optional inkl. Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
lCount = lCount + 1
ReDim Preserve arrFiles(1 To lCount)
arrFiles(lCount) = IIf(FolderName, FileItem, FileItem.Name)
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub Dateien_Bearbeiten()
' Kopiert Zeilen aus einer Masterdatei in viele Zieldateien
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim rng3 As Range, rng21 As Range
Dim wbMaster As Workbook, wksMaster As Worksheet
Dim intI As Integer
Dim Verzeichnis As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.ButtonName = "Ordner wählen"
.Title = "Bitte Hauptordner auswählen"
.InitialView = msoFileDialogViewList
If .Show False Then
Verzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Variablen im zurücksetzen
Erase arrFiles
lCount = 0
'Dateiliste erstellen
Call ListFilesInFolder(SourceFolderName:=Verzeichnis, _
DateiFormat:="*.xls*", _
IncludeSubfolders:=True, _
FolderName:=True)
If lCount > 0 Then
Set wbMaster = Application.Workbooks("MasterDatei.xlsm") 'Masterdatei muss geöffnet sein
Set wksMaster = wbMaster.Sheets(1) 'Tabellenblatt mit den zu kopierenden Zeilen
With wksMaster
'Zeilen, die in den Dateien nach Zeile 3 eingefügt werden sollen
Set rng3 = .Range(.Rows(5), .Rows(6))
'Zeilen, die in den Dateien nach Zeile 21 eingefügt werden sollen
Set rng21 = .Range(.Rows(10), .Rows(11))
End With
Application.ScreenUpdating = False
For intI = 1 To lCount
If LCase(arrFiles(intI)) LCase(wbMaster.FullName) Then
Application.StatusBar = "Datei " & intI & " von " & lCount & " wird bearbeitet: " _
& arrFiles(intI)
'Zieldatei öffnen
Set wbZiel = Workbooks.Open(Filename:=arrFiles(intI), ReadOnly:=False)
'Zieltabelle setzen = 1. Tabellenblatt in Quelldatei
Set wksZiel = wbZiel.Worksheets(1) 'ggf. Name/Nummer anpassen
With wksZiel
'Zeilen unterhalb Zeile 21 in Zieltabelle kopieren
.Range(.Rows(22), .Rows(22 + rng21.Rows.Count - 1)).Insert
.Range(.Rows(22), .Rows(22 + rng21.Rows.Count - 1)).Clear
rng21.Copy .Range(.Rows(22), .Rows(22 + rng21.Rows.Count - 1))
'Zeilen unterhalb Zeile 3 in Zieltabelle kopieren
.Range(.Rows(4), .Rows(4 + rng3.Rows.Count - 1)).Insert
.Range(.Rows(4), .Rows(4 + rng3.Rows.Count - 1)).Clear
rng3.Copy .Range(.Rows(4), .Rows(4 + rng3.Rows.Count - 1))
'Spaltenbreite anpassen
.Columns(8).ColumnWidth = 15
End With
wbZiel.Close Savechanges:=True
Set wksZiel = Nothing
Set wbZiel = Nothing
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Fertig"
Else
MsgBox "Keine Excel-Dateien in Verzeichnissen gefunden"
End If
End Sub