Summierung ohne Datei zu öffnen
chris58
Ich habe noch eine Frage. Ich habe diesen Code jetzt nach allen Möglichkeiten getestet. Der Code summiert in einem Ordner alle Dateien die sich dort befinden. Also man muß nicht jede einzelne Datei öffnen.
Ein Problem bleibt offen. Ich habe so um die 60 Konten die summiert werden sollen. Es geht alles bestens, wenn alle bebucht sind. Doch wenn ein Konto keine Buchung erhalten hat, dann bricht der Code ab. Wo, was, kann ich einbauen, das er trotzdem keinen Fehler anzeigt. Dann würde er klaglos laufen.
Kann mir wer heflen - Danke
chris58
Option Explicit
Private Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Sub Makro1()
Dim Pfad As String
Dim i As Integer
Dim dateiname As String
Dim vntTemp1 As Variant, vntTemp2 As Variant
Dim lngRow As Long, lngLastRow As Long
Dim rngSummen As Range
With Application.FileSearch
.NewSearch
Pfad = Ordnerwählen("Ab welchem Verzeichnis einlesen?")
End With
If IsDiskFolder(Pfad) = False Then
MsgBox ("Das angegebene Verzeichnis existiert nicht!")
Exit Sub
End If
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = Pfad
.SearchSubFolders = False
.Filename = "*Monatsliste*" 'Dateinamensmuster !!!!!!!!!!
'z.B. "*VB002008*" , damit werden alle Dateien nacheinander die dem Muster entsprechen geöffnet.
If .Execute() = 0 Then MsgBox ("Keine Dateien zur Verarbeitung gefunden"): Exit Sub
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Set rngSummen = Nothing
Workbooks.OpenText Filename:=.FoundFiles(i)
dateiname = Right$(.FoundFiles(i), Len(.FoundFiles(i)) - InStrRev(.FoundFiles(i), "\"))
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
vntTemp1 = Month(Cells(lngLastRow, 1).Value)
For lngRow = lngLastRow To 1 Step -1
If lngRow > 1 Then
vntTemp2 = Month(Cells(lngRow, 1).Value)
Else
vntTemp2 = 0
End If
If vntTemp2 vntTemp1 Then
Rows(lngLastRow + 1).Insert
Cells(lngLastRow + 1, 4).Formula = "=Sum(" & Range(Cells(lngRow + 1, 4), Cells(lngLastRow, 4)).Address & ")"
Cells(lngLastRow + 1, 5).Formula = "=Sum(" & Range(Cells(lngRow + 1, 5), Cells(lngLastRow, 5)).Address & ")"
Cells(lngLastRow + 1, 6).Formula = "=Sum(" & Range(Cells(lngRow + 1, 6), Cells(lngLastRow, 6)).Address & ")"
Range(Cells(lngLastRow + 1, 1), Cells(lngLastRow + 1, 6)).Interior.Color = vbGreen
Range(Cells(lngLastRow + 1, 1), Cells(lngLastRow + 1, 6)).Font.Bold = True
If vntTemp2 0 Then vntTemp1 = Month(Cells(lngRow, 1).Value)
If Not rngSummen Is Nothing Then
Set rngSummen = Union(rngSummen, Cells(lngLastRow + 1, 1))
Else
Set rngSummen = Cells(lngLastRow + 1, 1)
End If
lngLastRow = lngRow
End If
Next lngRow
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(lngLastRow + 2, 4).Formula = "=Sum(" & rngSummen.Offset(0, 3).Address & ")"
Cells(lngLastRow + 2, 5).Formula = "=Sum(" & rngSummen.Offset(0, 4).Address & ")"
Cells(lngLastRow + 2, 6).Formula = "=Sum(" & rngSummen.Offset(0, 5).Address & ")"
Range(Cells(lngLastRow + 2, 1), Cells(lngLastRow + 2, 6)).Interior.Color = vbRed
Range(Cells(lngLastRow + 2, 1), Cells(lngLastRow + 2, 6)).Font.Bold = True
Application.ScreenUpdating = True
Workbooks(dateiname).Close SaveChanges:=True
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Private Function Ordnerwählen(ByVal strTitle As String) As String
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BROWSEINFO
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function
Function IsDiskFolder(ByVal fName As String) As Boolean
'liefert True zurück, wenn der Ordner existiert
If (Dir(fName, vbDirectory) "") Then
IsDiskFolder = True
Else
IsDiskFolder = False
End If
End Function