Hallo,
könnte so gehen, aber ohne VBA Kenntnisse schwer nachvollziehbar?!
kommt als Code in Modul1
Option Explicit
Sub Beispiel()
Dim strFolder$
Dim n&, nRow&, lngFileCount&
Dim ArrayData(), ArrayFile(), ArFileFilter()
Dim varValues
strFolder = "G:\1 Forum\" 'Such-Ordner
ArFileFilter = Array("pos?* *.elt") 'Filter suche
FindFiles ArrayFile, strFolder, lngFileCount, ArFileFilter, True, False
If lngFileCount > 0 Then
Redim ArrayData(1 To lngFileCount, 1 To 4)
For n = Lbound(ArrayFile) To Ubound(ArrayFile)
'ohne Schnittstempel
If InStr(ArrayFile(n), "Schnittstempel") = 0 Then
nRow = nRow + 1
varValues = Split(ArrayFile(n), " ")
'Nummer ohne Pos
ArrayData(nRow, 1) = Replace(varValues(0), "pos", "")
'Name ohne .elt
ArrayData(nRow, 4) = Replace(varValues(Ubound(varValues)), ".elt", "")
' Name = Grundplatte Spalte C "ST52"
' Name = Druckplatte Spalte C "1.2379"
' Name = Halteplatte Spalte C "1.1730"
Select Case ArrayData(nRow, 4)
Case "Grundplatte": ArrayData(nRow, 3) = "ST52"
Case "Druckplatte": ArrayData(nRow, 3) = "1.2379"
Case "Halteplatte": ArrayData(nRow, 3) = "1.1730"
End Select
End If
Next
' Ausgabe
If nRow > 0 Then
With Tabelle1 'Ausgabetabelle angeben
With .Range("A2").Resize(nRow, Ubound(ArrayData, 2))
.Value = ArrayData
End With
End With
End If
End If
End Sub
kommt als Code in Modul2
Option Explicit
'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 Const INVALID_HANDLE_VALUE = -1&
Private Const MAX_PATH = 260&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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 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
Sub FindFiles(ArrayData(), ByVal strFolderPath As String, _
ByRef lngFileCount As Long, ArFileFilter, Optional SubFolder As Boolean = True, Optional booFullPath 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, booFullPath
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, SubFolder, booFullPath
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, Optional booFullPath As Boolean = True)
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) = _
IIf(booFullPath, strFolderPath & strFileName, strFileName)
lngFileCount = lngFileCount + 1
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Next
End Sub
Gruß Tino