Mehrere Dateien kopieren, die Variable im Dateinamen haben

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von Svenko.

    Mehrere Dateien kopieren, die Variable im Dateinamen haben

    Hallo,

    ich habe ein Makro geschrieben, welches in der Spalte A nacheinander eine Nummer speichert und diese
    Nummer zusammen mit einem gespeichertem Pfad und der Endung „.pdf“ als
    absoluten Pfad speichert. Nach diesem Prozess wird die Datei aus dem
    Quellordner in einen Zielordner gespeichert.

    Mein Problem:
    Manchmal gibt es mehrere Dateien - alles vom selbem Typ - mit derselben Nummer (z. B. 00343 und
    00343_2012 oder 00343_2012_2). Bei so einem Fall sollten alle diese Dateien in
    den Zielordner gespeichert werden. Wie müsste ich es programmieren, dass der
    Dateiname eben nur „Like“ 00343 ist?

    Hier mein bisheriger Code (Paar Sachen sind nur zum
    Test da):
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. Sub test()
    3. Dim oldFolder As String
    4. Dim newFolder As String
    5. Dim file As String
    6. Dim iRow As String
    7. iRow = 1
    9. Dim laufwerk As String
    10. Dim artNr As String
    11. Dim laenge As Integer
    14. On Error GoTo ErrHandler
    16. ' Warnhinweis
    17. If MsgBox("Bitte stellen Sie folgendes sicher:" & Chr(13) & "" & Chr(13) & "1. Alle Artikelnummern stehen in Spalte A" & Chr(13) & "2. Es befinden sich keine Leerzeilen in Spalte A", vbOKCancel + vbExclamation, "Achtung!") = vbOK Then
    19. 1:
    20. ' Auswahl des Quellordners
    21. MsgBox ("Bitte Quellordner auswählen.")
    22. With Application.FileDialog(msoFileDialogFolderPicker)
    23. If .Show = True Then
    24. MyFolder = .SelectedItems(1)
    25. Else
    26. Exit Sub
    27. End If
    28. End With
    29. oldFolder = MyFolder & "\"
    31. ' Bestätigung des Quellordners
    32. If MsgBox("Quellordner:" & Chr(13) & oldFolder, vbOKCancel, "Quellordner") = vbCancel Then
    33. GoTo 1
    34. End If
    36. 2:
    37. ' Auswahl des Zielordners
    38. MsgBox ("Bitte Zielordner auswählen.")
    39. With Application.FileDialog(msoFileDialogFolderPicker)
    40. If .Show = True Then
    41. MyFolder = .SelectedItems(1)
    42. Else
    43. Exit Sub
    44. End If
    45. End With
    46. newFolder = MyFolder & "\"
    48. ' Bestätigung des Zielordners
    49. If MsgBox("Zielordner:" & Chr(13) & newFolder, vbOKCancel, "Zielordner") = vbCancel Then
    50. GoTo 2
    51. End If
    53. '' Bearbeitung vom Problem
    54. ' Alle Zellen mit Inhalt werden markiert
    55. Selection.SpecialCells(xlCellTypeConstants).Select
    56. ' Markierte Zellen werden als Text formatiert
    57. Selection.NumberFormat = "@"
    59. Do
    60. ' Zelle A1 wird Ausgewählt
    61. Cells(iRow, 1).Select
    62. ' Aktive Artnr. speichern
    63. artNr = ActiveCell.Value
    64. ' Überprüfung der Länge der ausgewählten Artnr.
    65. laenge = Len(artNr)
    66. ' Überprüfung ob Ausgewählte Artnr. zu kurz ist, weil Nullen fehlen
    67. Select Case laenge
    68. Case Is = 1
    69. ActiveCell.Value = "0000" & artNr
    70. Case Is = 2
    71. ActiveCell.Value = "000" & artNr
    72. Case Is = 3
    73. ActiveCell.Value = "00" & artNr
    74. Case Is = 4
    75. ActiveCell.Value = "0" & artNr
    76. End Select
    78. ' Genauer Dateipfad wird erzeugt
    79. file = ActiveCell.Value & ".pdf"
    80. ' Datei wird von Quellordner in Zielordner kopiert
    81. FileCopy oldFolder & file, newFolder & file
    82. ' Zelle wird grün gefärbt
    83. ActiveCell.Interior.Color = vbGreen
    84. weiter:
    85. iRow = iRow + 1
    87. Loop Until IsEmpty(Cells(iRow, 1))
    88. Exit Sub
    90. ErrHandler:
    91. ' Zelle wird rot gefärbt, wenn Datei nicht vorhanden
    92. ActiveCell.Interior.Color = vbRed
    93. Resume weiter
    95. Exit Sub
    96. Else
    97. Exit Sub
    98. End If
    99. End Sub


    Wäre voll cool wenn es klappt, danke :D

Facebook
Telefonspende