根据单元格值创建子文件夹并将图像复制到同一文件夹

Question

我正在从事一个大型项目，此时更改代码的能力已停止。所以需要帮助。

主文件夹有子文件夹和MSR文件，里面有相互关联的命名。我们必须把这个主文件夹路径输入到我们的excel文件的D4中。 MSR 包含与每个图像相关的所有信息。图像文件夹包含所有图像，我们需要将所有图像分类到子文件夹中。 我们已经有了一个宏，它可以检索一个列表，其中图像与正确的位置相关联。 （见第三张图） 我们现在要做的是在这种情况下在对应于“*test”的主文件夹中创建子文件夹，并且在这个新文件夹中应该根据有多少唯一位置创建子文件夹。在这种情况下，它将产生 18 个子文件夹。 D 列和 E 列的组合是唯一的位置（前 2 个示例 = 13200-9496 和 13213-9506）。与此位置对应的所有图像文件都应放在新的子文件夹中。

我希望这有点清楚？

主文件夹概览

子文件夹概览

输出数据

代码：

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False


    Dim WBMacro As Workbook
    Set WBMacro = ActiveWorkbook
    Dim FoName As Range
    Set FoName = WBMacro.Sheets("Instructions").Range("B4")


        FolderName = FoName
        If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
        FName = Dir(FolderName & "*.msr")

        'loop through the files
        Do While Len(FName)

              Dim WBMSR As Workbook
              Set WBMSR = Workbooks.Open(FolderName & FName)

            With WBMSR

    Columns("A:A").Select

        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True


     'Create new tab to copy data of interest in
     Dim WsMSR As Worksheet
     Set WsMSR = WBMSR.ActiveSheet
     WsMSR.Name = "MSRData"

     .Worksheets.Add

     Dim wsPictData As Worksheet
     Set wsPictData = WBMSR.Sheets("Sheet1")
     wsPictData.Name = "PictureInfo"

     'Define where to copy data to

     Dim RngPictName As Range
     Dim RngX As Range
     Dim RngY As Range

     Set RngPictName = wsPictData.Range("A2")
     Set RngXY = wsPictData.Range("B2")
     Set RngChipCoX = wsPictData.Range("D2")
     Set RngChipCoY = wsPictData.Range("E2")

     RngPictName.Offset(-1, 0) = "PictName"
     RngXY.Offset(-1, 0) = "DieX,DieY"
     RngChipCoX.Offset(-1, 0) = "ChipCoX"
     RngChipCoY.Offset(-1, 0) = "ChipCoY"


     'Find PictureName

     Dim RngPictStart As Range
     Dim RngPictStop As Range
     Dim RngPict As Range


    Dim strImage As String
    strImage = "&mp_image_name"

    Dim strChipNr As String
    strChipNr = "Chip_number"

    Dim strChipCo As String
    strChipCo = "Chip_coordinate"

    With WsMSR.Range("B:B")

     Set image = .Find(strImage, lookat:=xlPart, LookIn:=xlValues)

       If Not image Is Nothing Then
            FirstAddress = image.Address

            Do

                Set pict = image.Offset(0, 2)
                pict.Copy

                    If RngPictName = "" Then
                    RngPictName.PasteSpecial
                    Else
                    RngPictName.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
                    End If


                For i = 1 To 15

                    'Do

                        If image.Offset(i, 1).Value = strChipNr Then
                        Set XY = image.Offset(i, 2)
                        XY.Copy

                            If RngXY = "" Then
                            RngXY.PasteSpecial
                            Else
                            RngXY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
                            End If
                        End If

                        If image.Offset(i, 1).Value = strChipCo Then
                        Set ChipX = image.Offset(i, 2)
                        ChipX.Copy

                            If RngChipCoX = "" Then
                            RngChipCoX.PasteSpecial
                            Else
                            RngChipCoX.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
                            End If


                        Set ChipY = image.Offset(i, 4)
                        ChipY.Copy

                            If RngChipCoY = "" Then
                            RngChipCoY.PasteSpecial
                            Else
                            RngChipCoY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
                            End If
                        End If

                Next


                Set image = .FindNext(image)
                                    If image Is Nothing Then
                                        GoTo DoneFinding1
                                    End If


             Loop While image.Address <> FirstAddress


         End If

    End With

DoneFinding1:

    End With


    ' change wsPictData Column B with (x,Y) to 2 columns (B = X, C = Y)

    With wsPictData

    Columns("B:B").Select

        Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True



    End With


    WsMSR.Delete
    Dim WBMSRFileName As String
    WBMSRFileName = Left(WBMSR.Name, Len(WBMSR.Name) - 4)
    Dim relativePath As String
    relativePath = WBMSR.Path



    WBMSR.SaveAs Filename:=relativePath & "\" & "Pictures_" & WBMSRFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    WBMSR.Close (False)

      ' go to the next file in the folder

    FName = Dir


    Loop


    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox ("all Files in folder" & relativePath & " are analyzed")

这是一个阐明文件夹树的架构。图片测试是主文件夹（在此示例中，名称始终不同）。底部的灰色区域是宏需要制作的。在 Mainfolder 中，为每个“测试”创建一个带有“已过滤”附录的新文件夹，并在每个文件夹中创建一个新文件夹，该文件夹的位置包含在该位置拍摄的所有图像。

folder tree

msr file example

Answer 1

这会扫描 MAIN_FOLDER 以查找以 Pictures_ 开头的 excel 文件，打开它们并向下扫描从 A、D 和 E 列构建目标文件夹名称的行。我在每个阶段都放置了消息框，所以如果你单步完成，你可以学习这个怎么运作。如果您确认操作，它将创建子文件夹，但最后的实际复制方法被注释掉。详情请见FileSystemObject。

Sub imagemove()

    Const MAIN_FOLDER = "c:\temp\msr\"

    Dim FileName As String, wb As Workbook, ws As Worksheet
    Dim count As Long, iLastRow As Long, iRow As Long
    Dim sPictureFolder As String, sCopyFolder As String
    Dim sCopySubFolder As String, msg As String
    Dim sPictureName As String, sChipCoX As String, sChipCoY As String
    Dim sSrc As String, sDest As String

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    FileName = Dir(MAIN_FOLDER & "Pictures_*.xlsx")
    Do While Len(FileName) > 0

        ' determine picture folder from filename
        sPictureFolder = MAIN_FOLDER & Mid(FileName, 10, Len(FileName) - 14)
        sCopyFolder = sPictureFolder & "-Filtered"
        Debug.Print sPictureFolder, sCopyFolder

        ' check if folder exists
        If FSO.FolderExists(sCopyFolder) = False Then
            msg = sCopyFolder & " does not exist, do you want to create it"
            If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
                FSO.CreateFolder sCopyFolder
            Else
                Exit Sub
            End If
        End If

        ' scan down msr file
        Set wb = Workbooks.Open(MAIN_FOLDER & FileName, False, True)
        Set ws = wb.Sheets("PictureInfo")
        iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
       'Debug.Print FileName, iLastRow

        For iRow = 2 To iLastRow
            sPictureName = ws.Cells(iRow, 1) ' A
            sChipCoX = ws.Cells(iRow, 4) ' D
            sChipCoY = ws.Cells(iRow, 5) ' E

            ' ignore jpeg images
            If Right(sPictureName, 4) = "jpeg" Then GoTo skip

            sCopySubFolder = sCopyFolder & "\" & sChipCoX & "-" & sChipCoY

            ' check if sub folder exists
            If FSO.FolderExists(sCopySubFolder) = False Then
                msg = sCopySubFolder & " does not exist, do you want to create it"
                If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
                    FSO.CreateFolder sCopySubFolder
                Else
                    Exit Sub
                End If
            End If

            ' move locations
            sSrc = sPictureFolder & "\" & sPictureName
            sDest = sCopySubFolder & "\" & sPictureName

            ' check file exists
            If FSO.FileExists(sSrc) = True Then
                MsgBox "Copy from " & sSrc & " to " & sDest
               'FSO.CopyFile sSrc, sDest
            Else
                MsgBox sSrc & " does not exist", vbCritical, "File does not exist"
                'test FSO.CreateTextFile sDest
            End If

            Debug.Print "Copy", sSrc, "to", sDest
skip:
        Next

        count = count + 1
        FileName = Dir
    Loop

    MsgBox count & " Pictures_* files scanned in " & MAIN_FOLDER, vbInformation

End Sub

Answer 2

好的，我必须回答我的问题...我从图片文件中删除了所有 jpeg 文件，因此这些图像不会被复制，因此我创建了另一个循环。我首先将它放在您的循环中，但随后它会创建一个额外的空文件夹。但是现在我怕我放慢了很多宏？最好在你的循环中做，然后最后删除“-”文件夹？

Set wb = Workbooks.Open(MAIN_FOLDER & "\" & FileName, False, True)
       Set ws = wb.Sheets("PictureInfo")
       iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
       'Debug.Print FileName, iLastRow

            For iRow = 2 To sLastrow
                If Right(ws.Cells(iRow, 1).Text, 4) = "jpeg" Then ws.Cells(iRow, 1).EntireRow.Delete

            Next

       For iRow = 2 To iLastRow


            sPictureName = ws.Cells(iRow, 1) ' A
            sChipCoX = ws.Cells(iRow, 4) ' D
            sChipCoY = ws.Cells(iRow, 5) ' E
    ```