Datein eines Ordners öffnen und prüfen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Gustav!
Ich nehme mal an, das die Tabellen immer den selben Namen haben!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long

Sub GetSumAndMove()
Dim strPath As String, strMove As String, strSheet As String, strRange As String
Dim objFS As FileSearch, objFSO As Object
Dim lngIndex As Long, varResult As Variant

'#### Diese Angaben anpassen #######################

'zu untersuchendes Verzeichnis
strPath = "F:\Temp\"

'Ordner in den die Dateien verschoben werden sollen!
strMove = "F:\Temp\Leer"

'Name des Tabellenblattes!
strSheet = "Tabelle1"

'Bereich dessen Summe gebildet werden soll!
strRange = "C:C"

'###################################################

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If Right(strMove, 1) <> "\" Then strMove = strMove & "\"

MakeSureDirectoryPathExists strMove

Set objFS = Application.FileSearch
Set objFSO = CreateObject("Scripting.FileSystemObject")

With objFS
  .NewSearch
  .LookIn = strPath
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = False
  .Execute

  For lngIndex = 1 To .FoundFiles.Count

    varResult = GetValue(strPath, Replace(.FoundFiles(lngIndex), strPath, ""), strSheet, strRange)

    If IsNumeric(varResult) And varResult = 0 Then
      objFSO.MoveFile .FoundFiles(lngIndex), strMove
    End If

  Next

End With

Set objFS = Nothing
Set objFSO = Nothing

End Sub

Private Function GetValue(path As String, file As String, _
  sheet As String, ref As String) As Variant

Dim arg As String

If Right(path, 1) <> "\" Then path = path & "\"

If Dir(path & file) = "" Then
  GetValue = "File Not Found"
  Exit Function
End If

arg = "SUM('" & path & "[" & file & "]" & sheet & "'!" & _
  Range(ref).Address(, , xlR1C1) & ")"

GetValue = ExecuteExcel4Macro(arg)

End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Gustav!
Die Fehlermeldung kommt z.B. wenn du Verknüpfungen zu "*.xls" Dateien in dem Ordner stehen hast!
Das lässt sich auch abfangen!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long

Sub GetSumAndMove()
Dim strPath As String, strMove As String, strSheet As String, strRange As String
Dim objFS As FileSearch, objFSO As Object
Dim lngIndex As Long, varResult As Variant

'#### Diese Angaben anpassen #######################

'zu untersuchendes Verzeichnis
strPath = "F:\Temp\"

'Ordner in den die Dateien verschoben werden sollen!
strMove = "F:\Temp\Leer"

'Name des Tabellenblattes!
strSheet = "Tabelle1"

'Bereich dessen Summe gebildet werden soll!
strRange = "C:C"

'###################################################

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If Right(strMove, 1) <> "\" Then strMove = strMove & "\"

MakeSureDirectoryPathExists strMove

Set objFS = Application.FileSearch
Set objFSO = CreateObject("Scripting.FileSystemObject")

With objFS
  .NewSearch
  .LookIn = strPath
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = False
  .Execute

  For lngIndex = 1 To .FoundFiles.Count

    If objFSO.GetExtensionName(.FoundFiles(lngIndex)) = "xls" Then

      varResult = GetValue(strPath, Replace(.FoundFiles(lngIndex), strPath, ""), strSheet, strRange)

      If IsNumeric(varResult) And varResult = 0 Then
        objFSO.MoveFile .FoundFiles(lngIndex), strMove
      End If

    End If

  Next

End With

Set objFS = Nothing
Set objFSO = Nothing

End Sub

Private Function GetValue(path As String, file As String, _
  sheet As String, ref As String) As Variant

Dim arg As String

If Right(path, 1) <> "\" Then path = path & "\"

If Dir(path & file) = "" Then
  GetValue = "File Not Found"
  Exit Function
End If

arg = "SUM('" & path & "[" & file & "]" & sheet & "'!" & _
  Range(ref).Address(, , xlR1C1) & ")"

GetValue = ExecuteExcel4Macro(arg)

End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

Datein eines Ordners öffnen und prüfen?

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datein eines Ordners öffnen und prüfen?

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread