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