Excel VBA复制文件代码

Question

任何人都可以帮我修改下面的脚本来执行以下操作：

目前，如果在两个不同的文件夹中有两个不同大小的同名图像，如果找到的第一个版本与所需的文件大小不匹配，程序将完全跳过该图像。

我希望它跳过小尺寸图像，但是如果它在具有正确图像尺寸的另一个文件夹中出现相同名称，则会复制它。

以下是完整的程序代码：

Option Explicit

Const fileListRow = 1
Const fileListCol = 2
Const srcDirRow = 2
Const srcDirCol = 2
Const destDirRow = 3
Const destDirCol = 2
Const resultRow = 4
Const resultListCol = 1
Const resultFoundCol = 2
Const resultCopyCol = 3
Const percentageRow = 5
Const percentageCol = 4
Const fileSizeLimitRow = 4
Const fileSizeLimitCol = 5
Dim srcFileShortName As String
Dim srcFileFullName As String
Dim destFileFullName As String
Dim srcDir As String
Dim destDir As String
Const startRowSrcFileShortName = 7
Dim endRowSrcFileShortName As Long
Const startRowSrcFileFullName = 7
Const startColSrcFileFullName = 2
Dim endRowSrcFileFullName As Long
Dim searchFileAmount As Long
Dim foundFileAmount As Long
Dim copyFileAmount As Long
Dim fileSizeLimit As Long
Dim totalCopyFileSize As Long
Dim currentCopyFileSize As Long
Dim mainWS As Worksheet

Sub getFileList()

    Set mainWS = ThisWorkbook.Sheets("main")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainWS.Unprotect

    Dim x As Variant

    x = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt", Title:="Choose File List", MultiSelect:=False)

    If x = False Then
        Exit Sub
    End If

    ThisWorkbook.Sheets("main").Cells(fileListRow, fileListCol).Value = x

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    mainWS.Protect

End Sub

Sub getSrcDir()

    Set mainWS = ThisWorkbook.Sheets("main")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainWS.Unprotect

    Dim folderPath As String
    Dim result As Integer

    Dim dialog As Office.FileDialog

    Set dialog = Application.FileDialog(msoFileDialogFolderPicker)
    dialog.InitialFileName = ""
    result = dialog.Show()

    If result = -1 Then
        ThisWorkbook.Sheets("main").Cells(srcDirRow, srcDirCol).Value = dialog.SelectedItems(1)
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    mainWS.Protect

End Sub


Sub getDestDir()

    Set mainWS = ThisWorkbook.Sheets("main")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainWS.Unprotect

    Dim folderPath As String
    Dim result As Integer

    Dim dialog As Office.FileDialog

    Set dialog = Application.FileDialog(msoFileDialogFolderPicker)
    dialog.InitialFileName = ""
    result = dialog.Show()

    If result = -1 Then
        ThisWorkbook.Sheets("main").Cells(destDirRow, destDirCol).Value = dialog.SelectedItems(1)
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    mainWS.Protect

End Sub

Sub resetField()

    Dim totalRow As Long
    Set mainWS = ThisWorkbook.Sheets("main")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainWS.Unprotect


    mainWS.Cells(resultRow, resultListCol).Resize(1, 3).ClearContents
    mainWS.Cells(percentageRow, percentageCol).Resize(1, 3).ClearContents

    endRowSrcFileShortName = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).Row
    totalRow = endRowSrcFileShortName - startRowSrcFileShortName + 1

    If totalRow > 0 Then
        mainWS.Cells(startRowSrcFileShortName, 1).Resize(totalRow, 3).ClearContents
        mainWS.Cells(startRowSrcFileShortName, 1).Resize(totalRow, 3).Interior.ColorIndex = xlColorIndexNone
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    mainWS.Protect

End Sub

Sub FindFile()

    Call resetField

    Dim counter As Long
    Set mainWS = ThisWorkbook.Sheets("main")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainWS.Unprotect


    Dim fileName As String, textRow As String, fileNo As Integer
    fileName = mainWS.Cells(fileListRow, fileListCol)
    fileNo = FreeFile 'Get first free file number

    counter = startRowSrcFileShortName

    Open fileName For Input As #fileNo
    Do While Not EOF(fileNo)
       Line Input #fileNo, textRow
       mainWS.Cells(counter, 1).Value = textRow
       counter = counter + 1
    Loop
    Close #fileNo


    srcDir = mainWS.Cells(srcDirRow, srcDirCol).Value

    endRowSrcFileShortName = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).Row

    searchFileAmount = 0
    For counter = startRowSrcFileShortName To endRowSrcFileShortName
        srcFileShortName = mainWS.Cells(counter, 1).Value
        If srcFileShortName <> "" Then
            searchFileAmount = searchFileAmount + 1
        End If
    Next counter
    mainWS.Cells(resultRow, 1).Value = searchFileAmount & " Files Searched"

    If searchFileAmount > 0 Then
        foundFileAmount = 0
        For counter = startRowSrcFileShortName To endRowSrcFileShortName
            srcFileShortName = mainWS.Cells(counter, 1).Value
            If srcFileShortName <> "" Then
                srcFileFullName = ""
                Call FindFileName1(srcDir)
                Call FindFileName2(srcDir)
                If srcFileFullName = "" Then
                    mainWS.Cells(counter, startColSrcFileFullName).Value = "N/A"
                    mainWS.Cells(counter, startColSrcFileFullName).Interior.Color = RGB(255, 0, 0)
                Else
                    mainWS.Cells(counter, startColSrcFileFullName).Value = srcFileFullName
                    foundFileAmount = foundFileAmount + 1
                End If
            Else
                mainWS.Cells(counter, startColSrcFileFullName).Value = "N/A"
            End If
        Next counter
    End If
    mainWS.Cells(resultRow, resultFoundCol).Value = foundFileAmount & " Files Found"

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    mainWS.Protect

End Sub

Private Function FindFileName1(srcDir) '²éÕÒԴ·¾¶
    Dim fso, fld, fsb
    Dim fd, f
    If srcFileFullName <> "" Then Exit Function 'ÕÒµ½ºóÍ˳ö
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(srcDir)

    For Each f In fld.Files '±éÀúÔ´Îļþ¼ÐÖеÄËùÓÐÎļþ
        If CaseCheckBox.Value = True Then
            If f.Name = srcFileShortName Then '±È½ÏÁ½¸öÎļþÃû£¬Çø·Ö´óСд
                srcFileFullName = fld.Path & "\" & f.Name
                Exit Function 'ÕÒµ½ºóÍ˳ö
            End If
        Else
            If UCase(f.Name) = UCase(srcFileShortName) Then '±È½ÏÁ½¸öÎļþÃû,²»Çø·Ö´óСд
                srcFileFullName = fld.Path & "\" & f.Name
                Exit Function 'ÕÒµ½ºóÍ˳ö
            End If
        End If
    Next

End Function


Private Function FindFileName2(srcDir) 'µÝ¹éËÑÑ°´úÂë
    Dim fso, fld, fsb
    Dim fd, f
    If srcFileFullName <> "" Then Exit Function 'ÕÒµ½ºóÍ˳öµÝ¹é
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(srcDir)
    Set fsb = fld.SubFolders

    For Each fd In fsb '±éÀú¸ÃÎļþ¼ÐµÄËùÓÐ×ÓÎļþ¼Ð
        For Each f In fd.Files '±éÀúÿ¸ö×ÓÎļþ¼ÐÖеÄËùÓÐÎļþ
            If CaseCheckBox.Value = True Then
                If f.Name = srcFileShortName Then '±È½ÏÁ½¸öÎļþÃû£¬Çø·Ö´óСд
                    srcFileFullName = fd.Path & "\" & f.Name
                    Exit Function 'ÕÒµ½ºóÍ˳öµÝ¹é
                End If
            Else
                If UCase(f.Name) = UCase(srcFileShortName) Then '±È½ÏÁ½¸öÎļþÃû,²»Çø·Ö´óСд
                    srcFileFullName = fd.Path & "\" & f.Name
                    Exit Function 'ÕÒµ½ºóÍ˳öµÝ¹é
                End If
            End If
        Next
        Call FindFileName2(fd.Path) '±¾Îļþ¼Ð¼ì²éÍê±Ïºó£¬¼ÌÐøÉî²ãËÑËØÆä×ÓÎļþ¼Ð
    Next
End Function

Sub CopyFile()

    Dim counter As Long
    Dim fileSize As Long
    Set mainWS = ThisWorkbook.Sheets("main")
    'Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    mainWS.Unprotect

    srcDir = mainWS.Cells(srcDirRow, srcDirCol).Value

    endRowSrcFileFullName = mainWS.Cells(mainWS.Rows.Count, startColSrcFileFullName).End(xlUp).Row

    copyFileAmount = 0
    fileSizeLimit = mainWS.Cells(fileSizeLimitRow, fileSizeLimitCol).Value * 1024 * 1024
    totalCopyFileSize = 0
    currentCopyFileSize = 0

    If foundFileAmount > 0 Then
        For counter = startRowSrcFileFullName To endRowSrcFileFullName
            srcFileFullName = mainWS.Cells(counter, startColSrcFileFullName).Value
            If srcFileFullName <> "N/A" Then
                fileSize = FileLen(srcFileFullName)
                If fileSize >= fileSizeLimit Then
                    totalCopyFileSize = totalCopyFileSize + fileSize
                End If
            End If
        Next counter
    End If

    If foundFileAmount > 0 Then
        For counter = startRowSrcFileFullName To endRowSrcFileFullName
            srcFileFullName = mainWS.Cells(counter, startColSrcFileFullName).Value
            If srcFileFullName <> "N/A" Then
                fileSize = FileLen(srcFileFullName)
                If fileSize >= fileSizeLimit Then
                    destFileFullName = mainWS.Cells(destDirRow, destDirCol) & "\" & mainWS.Cells(counter, 1)
                    On Error Resume Next
                        FileCopy srcFileFullName, destFileFullName
                    If Err.Number <> 0 Then
                        mainWS.Cells(counter, resultCopyCol) = "Error"
                        mainWS.Cells(counter, resultCopyCol).Interior.Color = RGB(255, 0, 0)
                    Else
                        mainWS.Cells(counter, resultCopyCol) = "OK"
                        copyFileAmount = copyFileAmount + 1
                        currentCopyFileSize = currentCopyFileSize + fileSize
                        mainWS.Cells(percentageRow, percentageCol).Value = currentCopyFileSize / totalCopyFileSize
                    End If
                Else
                    mainWS.Cells(counter, resultCopyCol) = "FileSize:" & fileSize & "Bytes,Skipped"
                End If
            End If
        Next counter
    End If
    mainWS.Cells(resultRow, resultCopyCol).Value = copyFileAmount & " Files Copied"

    'Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    mainWS.Protect


End Sub