Microsoft Excel

Herbers Excel/VBA-Archiv

alle dateien eines Ordners öffnen und Werte kopier

Betrifft: alle dateien eines Ordners öffnen und Werte kopier von: Schmidt
Geschrieben am: 02.09.2014 20:43:27

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

  

Betrifft: AW: alle dateien eines Ordners öffnen und Werte kopier von: fcs
Geschrieben am: 03.09.2014 02:06:46

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



  

Betrifft: AW: alle dateien eines Ordners öffnen und Werte kopier von: Werner
Geschrieben am: 03.09.2014 19:35:16

Hallo Franz
dein Code läuft einwandfrei
Du hast wohl noch eine Nachtschicht eingelegt um die Fragen zu beantworten (siehe Sendezeit)

Danke nochmals
Werner


 

Beiträge aus den Excel-Beispielen zum Thema "alle dateien eines Ordners öffnen und Werte kopier"