Anzeige
Archiv - Navigation
1368to1372
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
Inhaltsverzeichnis

kopieren von Zeilen aus Datei in mehrere Datei

kopieren von Zeilen aus Datei in mehrere Datei
14.07.2014 13:23:13
Zeilen
Hallo zusammen,
ich habe da ein kleines Problem. Ich habe schon in unzähligen Foren gestöbert, bisher aber keine zufriedenstellende Lösung gefunden. Liegt wohl auch daran, dass meine vba-Kenntnisse eher als sehr bescheiden zu bezeichnen sind.
Ich habe also mehrere (ca. 500) Exceldateien auf mehrere Unterverzeichnisse verteilt und in jede Datei müssen jeweils mit Inhalt und Formatierung (Zellen verbunden, festgelegte Spaltenhöhe usw.) Zeilen eingefügt werden. Einmal müssen 2 Zeilen in jede Datei nach der 3. Zeile eingefügt/kopiert werden und einmal 2 Zeilen nach der 21 Zeile. Die einzufügenden Zeilen sollen von einer Vaterexceldatei abgerufen werden. Weiterhin muss in jeder Exceldatei die Spalte H verbreitert werden. Kann mir hier bitte ein netter Mensch helfen?

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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

Anzeige

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige