Create subfolders based on cell value and copy images to same folder - excel

Question

I am working on a big project and the ability to change the code stopped at this point. So help is needed please.
The main folders have subfolders and MSR files inside which are related to eachother with the naming.We have to input this main folder path into D4 on our excel file.
The MSR have all the info related to every image. Image folders have all the images inside and we need to sort the all into subfolders.
We already have a macro that retrieves a list on which images are correlated to the correct position. ( see third image)
What we want do now is creating subfolders into the main folder that corresponds to the "*test" in this case and in this new folder there should be subfolders created based on how many unique places there are. In this case it would result in 18 subfolder. The combination of Column D and E are the unique places (first 2 examples = 13200-9496 and 13213-9506). All the image files that corrospond to this place should be put in the new subfolder.
I hope this is somewhat clear?
Main folder overview
Sub folder overview
Output data
Code:
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")
This is a schema to clarify the folder tree. Picture test is the main folder (in this example, name is always different). The grey area on the bottom is wat the macro needs to make. Inside Mainfolder, create for every "test" a new folder with appendix "filtered" and in every folder new folders with the location which hold all the images that were taken on that location.
folder tree
msr file example

Answer 1

This scans the MAIN_FOLDER for excel files starting with Pictures_, opens them and scans down the rows building the destination folder names from columns A, D and E. I put message boxes at each stage so if you single step through you can study how it works. It will create sub-folders if you confirm the action but the actual copy method at the end is commented out. See FileSystemObject for more details.
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

Ok, I have to answer my question... I deleted all the jpeg files from the Pictures file so these images are not copied so I created another loop. I first had it inside your loop but then it would create an extra extra empty folder. But now I`m afraid that I slowed down the macro by a lot? Is it better to do it inside your loop and then delete the "-" folder in the end?
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
```