Ga naar inhoud

Macro zoeken bestand windows map+submappen


bennieboef
 Delen

Aanbevolen berichten

Hallo Allemaal,

Mijn macro zoekt in een windows map op de volgende manier : "prd." + <cell value> + ".dld"
Het probleem is dat er niet wordt gezocht in inderliggende bmappen

Hier de macro :

Option Explicit

Sub Find_DLD()
Dim AckTime As Integer, InfoBox As Object
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String, currentpath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim sFileType1 As String

Dim bContinue As Boolean

bContinue = True
iRow = 2

' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "S:"
sFileType = ".dld" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
sFileType1 = "prd."


' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

If Len(Range("E" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Klaar.", _
AckTime, "Hieperdepiep", 0)
Case 1, -1
Exit Sub
End Select
Else
' CHECK IF FILES EXISTS.

If Len(Dir(sSourcePath & sFileType1 & Range("E" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("F" & CStr(iRow)).Value = "Geen kantprogramma"
Range("F" & CStr(iRow)).Font.Bold = True
Else
Range("F" & CStr(iRow)).Value = "Kantprogramma bestaat!"
Range("F" & CStr(iRow)).Font.Bold = False

End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub

Het zou fantastisch zijn al iemand deze code zo kan aanpassen dat de macro ook in de onderliggende mappen van s:\ gaat zoeken.

Alvast bedankt voor jullie hulp.

 

Bijlage :  bestand met macro.

Controle dxf + kantprogramma.xlsm

Link naar reactie
Delen op andere sites

Laten we hiermee beginnen.


 

Sub Find_DLD()
Dim AckTime As Integer, InfoBox As Object
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sFileType As String
Dim sFileType1 As String
Dim bContinue As Boolean
Dim found As Boolean, fl As Object, fld As Object

bContinue = True
iRow = 2

' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "S:"
sFileType = ".dld" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
sFileType1 = "prd."


' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

    If Len(Range("E" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
        Set InfoBox = CreateObject("WScript.Shell")
        AckTime = 1
        Select Case InfoBox.Popup("Klaar.", AckTime, "Hieperdepiep", 0)
            Case 1, -1
            Exit Sub
        End Select
    Else
        On Error Resume Next
        With CreateObject("scripting.filesystemobject")
            For Each fl In .getfolder(sSourcePath).Files
                If fl.Name Like sFileType1 & Range("E" & CStr(iRow)).Value & sFileType Then found = True: GoTo gevonden
            Next
            For Each fld In .getfolder(sSourcePath).subfolders
                For Each fl In fld.Files
                    If fl.Name Like sFileType1 & Range("E" & CStr(iRow)).Value & sFileType Then found = True: GoTo gevonden
                Next
            Next
        End With
gevonden:
        If Not found Then
            Range("F" & CStr(iRow)).Value = "Geen kantprogramma"
            Range("F" & CStr(iRow)).Font.Bold = True
        Else
            Range("F" & CStr(iRow)).Value = "Kantprogramma bestaat!"
            Range("F" & CStr(iRow)).Font.Bold = False
        End If
    End If
    iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub

 

Link naar reactie
Delen op andere sites

 Delen

×
×
  • Nieuwe aanmaken...

Belangrijke informatie

We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.