AW: Hilfe beim ''such Makro''
02.10.2019 04:24:28
Uwe
Hallo Piet
In Spalte A stehen ArtikelCodes , die sind sechsstellig (123456).Die Hälfte in der Spalte A hat aber Größen Beschreibungen (123456-123 oder 123456-123-12) .Auf dem Laufwerk sind nur die ersten 6Zeichen hinterlegt , also bekomme ich für dich keine Hyperlinks .Das würde ich gern ändern.
Genutzt habe ich diesen Code:
kommt als Code in Modul1
Option Explicit
Sub Start()
Dim strFolder$, ArFileFilter()
Dim nCount&, lngFileCount&
Dim ArrayData(), ArrayFile(), sFile$
strFolder = "G:\VBA" 'Ordner angeben
With Tabelle1 'Tabelle anpassen
.Range("B2", .Cells(.Rows.Count, 2)).Clear 'Daten Spalte B löschen
nCount = .Cells(.Rows.Count, 1).End(xlUp).Row
If nCount
Sub 'keine Daten in Tabelle
ArrayData = .Range("A2", .Cells(nCount, 1))
strFolder = IIf(Right$(strFolder, 1) = "\", strFolder, strFolder & "\")
For nCount = 1 To Ubound(ArrayData)
If ArrayData(nCount, 1) "" Then
ArFileFilter = Array(ArrayData(nCount, 1) & "*.*") 'Filter für die Suche
'Suchen mit Unterordner sonst SubFolder = False
FindFiles ArrayFile, strFolder, lngFileCount, ArFileFilter, True
End If
If lngFileCount > 0 Then
'nur erste gefundene Datei Listen
sFile = ArrayFile(0)
'Hyperlink erstellen
ArrayData(nCount, 1) = _
"=HYPERLINK(""" & sFile & """,""" & Right$(sFile, Len(sFile) - InStrRev(sFile, " _
\")) & """)"
lngFileCount = 0
Else
ArrayData(nCount, 1) = "nix gefuden"
End If
Next nCount
.Range("B2").Resize(Ubound(ArrayData), 1).FormulaR1C1 = ArrayData
End With
Erase ArrayData
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)
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
Left 6 habe ich in der Zeile eingesetzt
Daten in Tabelle
ArrayData = .Range("A2", .Cells(nCount, 1))
Nur anscheinend nicht richtig?
Oder ist das die falsche stelle?
Oder reicht das nicht aus?
Ich weiß nicht weiter .
Danke für die schnelle Antwort!