Question

我在一个文件夹中有大量的.csv文件，每个文件中的分隔码很少。分隔码通常为5位数字，例如：B82A6。

我必须复制带有特定分隔码的文件，然后将其移至目标文件夹。

我是VBA的新手。我一直在寻找将其修改为适合自己使用的代码。

Sub Test()
Dim R As Range, r1 As Range
Dim SourcePath As String, DestPath As String, SeperationCode As String

SourcePath = "C:\Users\hr315e\Downloads\Nov_03_2019\"
DestPath = "C:\Users\hr315e\Downloads\Target\"
Set r1 = Range("A1", Range("A" & Rows.Count).End(xlUp))

For Each R In r1
    SeperationCode = Dir(SourcePath & R)

    Do While SeperationCode <> ""

        If Application.CountIf(r1, SeperationCode) Then
            FileCopy SourcePath & SeperationCode, DestPath & SeperationCode

            R.Offset(0, 1).Value = SeperationCode

        Else

            MsgBox "Bad file: " & SeperationCode & " ==>" & SeperationCode & "<== "

        End If

       SeperationCode = Dir(SourcePath & "B82A6" & R.Value & "B82A6")
    Loop
Next
End Sub

Answer 1

因此，这是适合您的代码。如您所见，这是我通过一些小更新就链接到您的代码的版本：

Sub GoThroughFilesAndCopy()

Dim BrowseFolder As String, DestinationFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim TempFileName As String
Dim CheckCode As String

Application.ScreenUpdating = False

    ' selecting the folder with files
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder with files"
        .Show
        On Error Resume Next
        Err.Clear
        BrowseFolder = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "You didn't select anything!"
            Application.ScreenUpdating = True
            Exit Sub
        End If
        On Error GoTo 0
    End With
    ' or you may hardcode it (data from your post):
    'BrowseFolder = "C:\Users\hr315e\Downloads\Nov_03_2019\"


    ' selecting the destination folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the the destination folder"
        .Show
        On Error Resume Next
        Err.Clear
        DestinationFolder = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "You didn't select anything!"
            Application.ScreenUpdating = True
            Exit Sub
        End If
        On Error GoTo 0
    End With
    ' or you may hardcode it (data from your post):
    'DestinationFolder = "C:\Users\hr315e\Downloads\Target\"


    CheckCode = "Some string" ' this is you check code


    Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
    Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object

    For Each FileItem In oFolder.Files 'looking through each file in selected forlder
        TempFileName = ""
        If UCase(FileItem.Name) Like "*.CSV*" Then 'try opening only .csv files
            TempFileName = BrowseFolder & Application.PathSeparator & FileItem.Name ' getting the full name of the file (with full path)
            If CheckTheFile(TempFileName, CheckCode) Then ' if the file passes the checking function
                If Dir(DestinationFolder & Application.PathSeparator & FileItem.Name) = "" Then 'if the file doesn't exist in destination folder
                    FileCopy Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name  ' it is copied to destination
                Else ' otherwise, there are to options how to deal with it further

                    'uncomment the part you need below:

                    ' this will Overwrite existing file
                    'FSO.CopyFile Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name

                    ' this will get new name for file and save it as copy
                    'FileCopy Source:=TempFileName, Destination:=GetNewDestinationName(FileItem.Name, DestinationFolder)

                End If
            End If
        End If
    Next

    Application.ScreenUpdating = True

End Sub

'////////////////////////////////////////////////////////////////////////

Function CheckTheFile(File As String, Check As String) As Boolean
Dim TestLine As String
Dim TestCondition As String

TestCondition = "*" & Check & "*" ' this is needed to look for specific text in the file, refer to Like operator fro details

CheckTheFile = False

Open File For Input As #1 ' open file to read it line by line
    Do While Not EOF(1)
        Line Input #1, TestLine ' put each line of the text to variable to be able to check it

        If TestLine Like TestCondition Then ' if the line meets the condition
            CheckTheFile = True             ' then function gets True value, no need to check other lines as main condition is met
            Close #1                        ' don't forget to close the file, beacuse it will be still opened in background
            Exit Function                   ' exit the loop and function
        End If
    Loop
Close #1 ' if condiotion is not found in file just close the file, beacuse it will be still opened in background

End Function

'////////////////////////////////////////////////////////////////////////

Function GetNewDestinationName(File As String, Destination As String) As String
Dim i As Integer: i = 1

Do Until Dir(Destination & Application.PathSeparator & "Copy (" & i & ") " & File) = "" ' if Dir(FilePath) returns "" (empty string) it means that the file does not exists, so can save new file with this name
    i = i + 1   ' incrementing counter untill get a unique name
Loop

GetNewDestinationName = Destination & Application.PathSeparator & "Copy (" & i & ") " & File ' return new file name

End Function

基本上，有一个子程序，主要是从链接的主题进行复制粘贴，还有两个简单的功能。

搜索字符串并将包含字符串的文件从源文件夹移动到目标文件夹

1 个答案: