时间戳

首页 > 解决方案 > 搜索字符串并将包含字符串的文件从源文件夹移动到目标文件夹

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

问题描述

我在一个文件夹中有大量 .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

标签： excelvba

解决方案

所以，这里的代码应该适合你。如您所见，这是我通过小更新链接到您的代码版本：

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

基本上，有一个子，主要是从链接主题复制粘贴，以及两个简单的功能。

推荐阅读