Bestanden kopieren op basis van deel bestandsnaam

[luifel]

Hallo,
In de bijlage wat voorbeeld bestanden.
Korte omschrijving:
Is het mogelijk om bestanden uit de ene map naar de andere te kopieren, op basis van de eerste karakters van een bestandsnaam?
Ik heb in de bijlage en voorbeeld zitten wat dit kan doen, indien de bestandsnaam helemaal identiek is.
Alvast bedankt voor eventuele suggesties!

 

[Elsendoorn2134]

Luifel,

Op zich is dit redelijk makkelijk, vervang de strFileNamePDF = Dir(strSourcePath & r & ".*") in je bestand door
strFileNamePDF = Dir(strSourcePath & r & "_*.*").
Echter als er meerdere bestanden zijn die met bijvoorbeeld "100_" beginnen moet je de Dir een paar keer
doorlopen tot Dir = "".

Veel Succes.

 

[luifel]

Dankje!
Ik zal het van het weekend eens proberen, hopelijk kom ik er uit!

 

[luifel]

Ik heb het '*' teken toegevoegd (zie rode * teken), nu pakt ie inderdaad het bestand wat nodig is.
Alleen wat je zegt over de 'loop' van de dir functie, waar zou ik die toe moeten voegen, en hoe?
Nu wordt er maar 1 bestand verzameld, ook al staan er meer in.

Sub PDFcopy()

strNotFoundPDF = "" 'zorgt er voor dat de lijst met niet gevonden artikelen leeg wordt gemaakt


  For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp)) 'checkt alle waarden (sapnrs) vanaf cel A2 naar beneden
  
    'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
    strFileNamePDF = Dir(strSourcePath & r & "[COLOR="#FF0000"]*[/COLOR].*")
    'Loop while files found
    If strFileNamePDF <> "" Then
      'Copy the file
      FileCopy strSourcePath & strFileNamePDF, strOutputPath & strFileNamePDF
      'Search the next file
    Else
      strNotFoundPDF = strNotFoundPDF & r & ".pdf" & Chr(13)
    End If
      strFileNamePDF = ""
 Next
  
If strNotFoundPDF <> "" Then
    MsgBox ("De volgende bestanden zijn niet gevonden :" & Chr(13) & Chr(13) & strNotFoundPDF)
    Else: MsgBox ("Alle bestanden zijn gevonden!"), vbInformation, "Geslaagd"
          Call Shell("explorer.exe" & " " & strOutputPath, vbNormalFocus)
   End If
   
   strNotFoundPDF = ""
   
End Sub

Daarnaast zou ik graag nog de lijst met niet gevonden nummers (strNotFoundPDF) wegschrijven in het excel bestand. Laten we zeggen in cel G2. Ik denk dat ik net voor de end sub iets in moet vullen op de plek van de "", maar wat zou dat dan moeten zijn? iets met range?
Alvast bedankt weer!

 

[Elsendoorn2134]

Luifel,

Google Dir in VBA voor het gebruik van de functie. Hierbij een werkend voorbeeld met gebruik van de dir formule.
Ook wordt de strNotFoundPDF variabele in G2 geplaatst.
Ik heb de tekst "Missende bestanden" even weggehaald, anders wordt die meegerekend in de lijst met de te verplaatsen
bestanden.

Option Explicit
Dim strSourcePath As String
Dim strOutputPath As String
Dim strNotFoundPDF As String
Dim strFileNamePDF As String
Dim r As Range

Sub PDFcopy()

strNotFoundPDF = "" 'zorgt er voor dat de lijst met niet gevonden artikelen leeg wordt gemaakt
strSourcePath = ActiveWorkbook.Path & "\Source\"
strOutputPath = ActiveWorkbook.Path & "\Output\"

For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp)) 'checkt alle waarden (sapnrs) vanaf cel A2 naar beneden
  
    'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
    strFileNamePDF = Dir(strSourcePath & r & "*.*")
    'Loop while files found
    If strFileNamePDF <> "" Then
        Do While strFileNamePDF <> ""
            'Copy the file
            FileCopy strSourcePath & strFileNamePDF, strOutputPath & strFileNamePDF
            'Search the next file
            strFileNamePDF = Dir
        Loop
    Else
        strNotFoundPDF = strNotFoundPDF & r & ".pdf" & Chr(13)
    End If
Next
  
If strNotFoundPDF <> "" Then
    MsgBox ("De volgende bestanden zijn niet gevonden :" & Chr(13) & Chr(13) & strNotFoundPDF)
    Sheets("Blad1").Range("G2") = strNotFoundPDF
Else
    MsgBox ("Alle bestanden zijn gevonden!"), vbInformation, "Geslaagd"
    Call Shell("explorer.exe" & " " & strOutputPath, vbNormalFocus)
End If
   
End Sub

Private Sub CommandButton1_Click()
    Call PDFcopy
End Sub

Veel Succes.

 

[luifel]

Hallo,
Bedankt voor de hulp! Ik heb het document precies gekregen zoals ik het voor ogen had, bedankt voor de hulp!
Luifel