Hallo,
ok. habe den Code so angepasst das er die Zeilen erst ab Zeile 5, Spalte 2 (also B5) nimmt.
Der Code geht davon aus, dass die Überschrift in der Zeile 4 steht und
dort setzte ich ans Ende der Tabelle eine neue Überschrift "Ex-Read".
In der Spalte wird das heutige Datum eingetragen,
damit wird gekennzeichnet dass diese Zeile gelesen wurde.
Wenn dort nichts steht geht der Code davon aus, dass diese Zeile noch nicht gelesen wurde. (dies erfolgt in den Dienstdateien)
Sollten diese Tabellen geschützt sein kann man im Code auch noch einbauen,
dass er den Schutz umgeht.
Den Pfad zu den Dateien kannst Du in der Zeile anpassen.
strOrdner = "G:\1 Forum\Dienstorte\"
In diesen Ordner und den Unterordnern werden alle Excel- Dateien daraufhin ausgelesen.
Der Code kommt entsprechend in zwei Module in die Übersichtsdatei und kann dort mittels Button oder so gestartet werden.
PS: ich würde dies erst anhand ein paar Beispieldateien (Kopie vom Original) testen
ob alles berücksichtigt wurde.
kommt als Code in Modul1
Option Explicit
Dim oApp As Excel.Application
Sub Start_Daten_Sammeln()
Dim ArrayTabNamen(), ArrayFiles(), varNewInhalt
Dim strOrdner$, varTab
Dim nFileCount&
'Tabellen die gelesen werden sollen, diese müssen auch in der Übersicht vorhanden sein
ArrayTabNamen = Array("EGZ 2011", "EGZ 2012", "EGZ Projekt 50plus 2011", "EGZ Projekt 50plus 2012", "16e Fälle", "EQ")
'Ordner anpassen wo die Dateien liegen **********************
strOrdner = "G:\1 Forum\Dienstorte\"
'************************************************************
If Right$(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
'Dateien suchen, die in diesen Ordner und Unterordner liegen
FindFiles ArrayFiles, strOrdner, nFileCount, Array("*.xls"), True
'Dateien gefunden?
If nFileCount = 0 Then
MsgBox "keine Dateien gefunden!"
Exit Sub
End If
For nFileCount = Lbound(ArrayFiles) To Ubound(ArrayFiles)
'Ist diese Datei die Übersichtsdatei?
If LCase(ArrayFiles(nFileCount)) <> LCase(ThisWorkbook.FullName) Then
'Daten aus den Tabellen lesen
Daten_Einlesen ArrayFiles(nFileCount), ArrayTabNamen
End If
Next nFileCount
On Error Resume Next
oApp.Quit
Set oApp = Nothing
End Sub
Sub Daten_Einlesen(ByVal strFile$, ArrayTabellen())
Dim varTab, ArrayData(), NewArray(), nColRefSpalte
Dim n&, nn&, nR&
If oApp Is Nothing Then
Set oApp = New Excel.Application
oApp.ScreenUpdating = False
oApp.EnableEvents = False
oApp.DisplayAlerts = False
End If
With oApp.Workbooks.Open(Filename:=strFile)
If Not .ReadOnly Then 'Datei darf nicht Schreibgeschützt sein
For Each varTab In ArrayTabellen
'prüfen ob es diese Tabelle in der Datei gibt
If CheckTab(oApp.Workbooks(.Name), varTab) Then
With .Sheets(varTab)
'in Zeile 4 die Überschrift Ex-Read suchen
nColRefSpalte = Application.Match("Ex-Read", .Rows(4), 0)
'Spalte Ex-Read gefunden? nein -> wird angelegt
If Not IsNumeric(nColRefSpalte) Then
With .Cells(4, .Columns.Count).End(xlToLeft).Offset(0, 1)
.Value = "Ex-Read"
.Font.Bold = True
nColRefSpalte = .Column
End With
End If
nColRefSpalte = nColRefSpalte - 1
With .Range(.Cells(4, 2), .Cells(.Rows.Count, 2).End(xlUp)).Resize(, nColRefSpalte)
ArrayData = .Value2
If Ubound(ArrayData) > 1 Then
Redim Preserve NewArray(1 To Ubound(ArrayData) - 1, 1 To nColRefSpalte - 1)
For n = 2 To Ubound(ArrayData)
If ArrayData(n, nColRefSpalte) = "" Then
nR = nR + 1
For nn = 1 To Ubound(ArrayData, 2) - 1
NewArray(nR, nn) = ArrayData(n, nn)
Next nn
ArrayData(n, nColRefSpalte) = Date
End If
Next n
If nR > 0 Then
.Value = ArrayData
With ThisWorkbook.Sheets(varTab)
With .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)
.Cells.Resize(nR, Ubound(NewArray, 2)) = NewArray
End With
End With
End If
Erase NewArray
nR = 0
nColRefSpalte = Empty
End If 'UBound(ArrayData) > 1
End With 'Range(...)
End With '.Sheets(varTab)
End If 'CheckTab(Workbooks(.Name), varTab)
Next varTab
.Close True 'Datei speichern u. schließen
Else
.Close False 'Datei nicht speichern und schließen
End If
End With
End Sub
'Hilfsfunktion zum prüfen ob Tabelle vorhanden ist
Function CheckTab(oWB As Workbook, ByVal strTabName$) As Boolean
On Error Resume Next
CheckTab = oWB.Sheets(strTabName).Index <> 0
End Function
kommt als Code in Modul2
Option Explicit
Option Private Module
'Teile des Originalcode von Nepumuk. ***********************************************************
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" ( _
ByVal hFindFile As Long) As Long
Private Enum FILE_ATTRIBUTE
FILE_ATTRIBUTE_READONLY = &H1
FILE_ATTRIBUTE_HIDDEN = &H2
FILE_ATTRIBUTE_SYSTEM = &H4
FILE_ATTRIBUTE_DIRECTORY = &H10
FILE_ATTRIBUTE_ARCHIVE = &H20
FILE_ATTRIBUTE_NORMAL = &H80
FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Private Const INVALID_HANDLE_VALUE = -1&
Private Const MAX_PATH = 260&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function MoveWindow Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
ByVal lpStr1 As String, _
ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
ByVal pList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassname As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Enum BIF_Flag
BIF_RETURNONLYFSDIRS = &H1
BIF_DONTGOBELOWDOMAIN = &H2
BIF_STATUSTEXT = &H4
BIF_RETURNFSANCESTORS = &H8
BIF_EDITBOX = &H10
BIF_VALIDATE = &H20
BIF_NEWDIALOGSTYLE = &H40
BIF_BROWSEINCLUDEURLS = &H80
BIF_BROWSEFORCOMPUTER = &H1000
BIF_BROWSEFORPRINTER = &H2000
BIF_BROWSEINCLUDEFILES = &H4000
BIF_SHAREABLE = &H8000
End Enum
Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1
Private s_BrowseInitDir As String
Public Function fncGetFolder( _
Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
Optional ByVal sPath As String = "C:\") As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
s_BrowseInitDir = sPath
With xl
.hwnd = FindWindow("XLMAIN", vbNullString)
.Root = 0
.Title = lstrcat(sMsg, "")
.Flags = lFlag
.FName = FuncCallback(AddressOf BrowseCallback)
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim$(FolderName)
FolderName = Left$(FolderName, Len(FolderName) - 1)
End If
fncGetFolder = FolderName
End Function
Private Function BrowseCallback( _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = BFFM_INITIALIZED Then
Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
Call CenterDialog(hwnd)
End If
BrowseCallback = 0
End Function
Private Function FuncCallback(ByVal nParam As Long) As Long
FuncCallback = nParam
End Function
Private Sub CenterDialog(ByVal hwnd As Long)
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub
Sub FindFiles(ArrayData(), ByVal strFolderPath As String, _
ByRef lngFilecount As Long, ArFileFilter, Optional SubFolder As Boolean = True)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
GetFilesInFolder ArrayData, strFolderPath, lngFilecount, ArFileFilter
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
If SubFolder = False Then Exit Sub 'ohne Unterordner
If (strDirName <> ".") And (strDirName <> "..") Then _
FindFiles ArrayData, strFolderPath & strDirName & "\", lngFilecount, ArFileFilter
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
End Sub
Sub GetFilesInFolder(ArrayData(), ByVal strFolderPath As String, _
ByRef lngFilecount As Long, ArFileFilter)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
Dim FileFilter
For Each FileFilter In ArFileFilter
lngSearch = FindFirstFile(strFolderPath & FileFilter, WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
FILE_ATTRIBUTE_DIRECTORY Then
strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
Redim Preserve ArrayData(lngFilecount)
ArrayData(lngFilecount) = strFolderPath & strFileName 'auflisten in Zelle
lngFilecount = lngFilecount + 1
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Next
End Sub
Gruß Tino