Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1376to1380
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

alle dateien eines Ordners öffnen und Werte kopier

alle dateien eines Ordners öffnen und Werte kopier
02.09.2014 20:43:27
Schmidt
Hallo ihr Helfer in der Not
Ich möchte aus einem Verzeichnis aus allen Dateien (gleich aufgebaut) den Bereich H39:J41 in ein neues Blatt untereinander kopieren. Ich habe mich durch die Recherche gewühlt und einen passenden Code von Fcs gefunden und ein wenig auf meine Bedürfnisse angepasst.Er Funktioniert aber nur unter Excel 2003 wegen "Application.FileSearch"
Frage : Wie bekomme ich diesen Code unter 2010 zum laufen?
Bei jeder Datei bekomme ich den Hinweis " Diese Datei enthält Verknüpfungen zu anderen Dateiquellen" "Nicht aktualisieren"
Habe ich den Befehl " Application.DisplayAlerts" verkehrt gesetzt?
Ich habe auch in "Diese Arbeitsmappe" folgenden Code ohne Erfolg eingesetzt
Private Sub Workbook_Open()
'Fragefenster ausschalten
Application.DisplayAlerts = False
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Fragefenster wieder einschalten
Application.DisplayAlerts = True
Wer Kann helfen?
Vielen Dank im voraus
Werner Schmidt
Sub DatenSammeln()
Dim wbNeu As Workbook, wksNeu As Worksheet, lZeileneu As Long
Dim wbQuelle As Workbook, wksQuelle As Worksheet, strQuelle, i As Integer
Dim strVerzeichnis, VerzAktuell As String, DateiNr As Integer
'Verzeichnis durch Wahl einer Datei wählen
VerzAktuell = VBA.CurDir
strVerzeichnis = Application.GetOpenFilename(Filefilter:="Exceldateien(*.xls),*.xls", _
Title:="Bitte Datei im gewünschten Verzeichnis wählen und öffnen")
If strVerzeichnis = False Then Exit Sub
strVerzeichnis = VBA.CurDir
VBA.ChDir VerzAktuell
With Application.FileSearch
.LookIn = strVerzeichnis
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
.Execute
Set wbNeu = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksNeu = wbNeu.Worksheets(1)
lZeileneu = 1
DateiNr = 1
Application.ScreenUpdating = False
For Each strQuelle In .FoundFiles
Application.StatusBar = "Datei Nummer  " & DateiNr & "  von  " _
& .FoundFiles.Count
Set wbQuelle = Workbooks.Open(Filename:=strQuelle, ReadOnly:=True)
'Fragefenster ausschalten
Application.DisplayAlerts = False
'Alle Tabellenblätter in Quelle abarbeiten
For i = 1 To wbQuelle.Worksheets.Count
Set wksQuelle = wbQuelle.Worksheets(i)
wksNeu.Cells(lZeileneu, 1) = wbQuelle.FullName
wksNeu.Cells(lZeileneu, 2) = wksQuelle.Name
With wksQuelle
'  Der Block H39:J41 soll kopiert werden
.Range(.Cells(39, 8), .Cells(41, 8)).Copy 'bereich H39:H41
'wksNeu.Cells(lZeileneu, 3).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 3).PasteSpecial Paste:=xlValues 'Zellewerte
.Range(.Cells(39, 9), .Cells(41, 9)).Copy 'bereich I39:I41
'wksNeu.Cells(lZeileneu, 4).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 4).PasteSpecial Paste:=xlValues 'Zellewerte
.Range(.Cells(39, 10), .Cells(41, 10)).Copy 'bereich J39:J41
'wksNeu.Cells(lZeileneu, 5).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 5).PasteSpecial Paste:=xlValues 'Zellewerte
'ggf. Code für weitere Zellbereiche ergänzen
End With
lZeileneu = lZeileneu + 3 'alt 1,
Next i
Application.DisplayAlerts = True
wbQuelle.Close savechanges:=False
DateiNr = DateiNr + 1
Next strQuelle
End With
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

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

Betreff
Datum
Anwender
Anzeige
AW: alle dateien eines Ordners öffnen und Werte kopier
03.09.2014 02:06:46
fcs
Hallo Schmidt,
zur Unterdrückung der Link-Aktualisierung muss du beim Öffnen der Datei einen entsprechenden Parameter "UpdateLinks" auf True oder False setzen.
      Set wbQuelle = Workbooks.Open(Filename:=strQuelle, ReadOnly:=True, UpdateLinks:=False)
Wenn das zu durchsuchende Verzeichnis keine Unterverzeichnis mit Exceldateien enthält, dann kann man mit Dir nach den Excel-Dateien suchen.
Falls auch Unterverzeichnisse abgearbeite werden müssen, dann muss eine Suchroutine mit "Scripting.FileSytemObject" eingesetzt werden.
Gruß
Franz
Option Explicit
'Quelle: http://www. _
herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: Franz Sielck 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 DatenSammeln()
Dim wbNeu As Workbook, wksNeu As Worksheet, lZeileneu As Long
Dim wbQuelle As Workbook, wksQuelle As Worksheet, strQuelle, i As Integer
Dim strVerzeichnis, VerzAktuell As String, intI As Integer
'Verzeichnis durch Wahl einer Datei wählen
VerzAktuell = VBA.CurDir
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte gewünschtes Verzeichnis wählen und öffnen"
.AllowMultiSelect = False
If .Show = -1 Then
strVerzeichnis = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Public Variablen im Modul zurücksetzen
Erase arrFiles
lCount = 0
Call ListFilesInFolder(SourceFolderName:=strVerzeichnis, _
DateiFormat:="*.xls*", _
IncludeSubfolders:=False, _
FolderName:=True)
If lCount > 0 Then
Set wbNeu = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksNeu = wbNeu.Worksheets(1)
lZeileneu = 1
Application.ScreenUpdating = False
For intI = 1 To lCount
If LCase(arrFiles(intI))  LCase(ThisWorkbook.FullName) Then
Application.StatusBar = "Datei " & intI & " von " & lCount & " wird bearbeitet: " _
& arrFiles(intI)
strQuelle = arrFiles(intI)
Set wbQuelle = Workbooks.Open(Filename:=strQuelle, ReadOnly:=True, UpdateLinks:=False)
'Alle Tabellenblätter in Quelle abarbeiten
For i = 1 To wbQuelle.Worksheets.Count
Set wksQuelle = wbQuelle.Worksheets(i)
wksNeu.Cells(lZeileneu, 1) = wbQuelle.FullName
wksNeu.Cells(lZeileneu, 2) = wksQuelle.Name
With wksQuelle
'  Der Block H39:J41 soll kopiert werden
.Range(.Cells(39, 8), .Cells(41, 8)).Copy 'bereich H39:H41
'wksNeu.Cells(lZeileneu, 3).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 3).PasteSpecial Paste:=xlValues 'Zellewerte
.Range(.Cells(39, 9), .Cells(41, 9)).Copy 'bereich I39:I41
'wksNeu.Cells(lZeileneu, 4).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 4).PasteSpecial Paste:=xlValues 'Zellewerte
.Range(.Cells(39, 10), .Cells(41, 10)).Copy 'bereich J39:J41
'wksNeu.Cells(lZeileneu, 5).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 5).PasteSpecial Paste:=xlValues 'Zellewerte
'ggf. Code für weitere Zellbereiche ergänzen
End With
lZeileneu = lZeileneu + 3 'alt 1,
Next i
wbQuelle.Close savechanges:=False
End If
Next intI
End If
Erase arrFiles
lCount = 0
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

Anzeige
AW: alle dateien eines Ordners öffnen und Werte kopier
03.09.2014 19:35:16
Werner
Hallo Franz
dein Code läuft einwandfrei
Du hast wohl noch eine Nachtschicht eingelegt um die Fragen zu beantworten (siehe Sendezeit)
Danke nochmals
Werner

311 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige