Hello guys !
I need a macro and your help !
Please see attached photo !
I want to move files that have names from column "A" (only that have STP ,PDF & DXF extensions) from current directory(e.g.: C:/Files) to subfolders (create new folders) based on "F" column (e.g.: C:/Files/Machining or C:/Files/Laser Cutting).
In column "G", I want a feedback (E.g.: STP & PDF Files moved / Files not found / DXF & PFD Files moved).
This manual process it a time consumer !
Thanks in advance !
Last edited by zEKeBv; 01-11-2021 at 03:43 PM.
there are file ext's in col a in your image. you'll obviously need that. this will also be of good help:
https://www.excelforum.com/tips-and-...and-files.html
everything you need is in the above link. you can move files 2 ways, and possibly more with this lang. using SHELL (DOS, the cmd prompt) and using XCOPY. or using the NAME statement.
https://docs.microsoft.com/en-us/off...name-statement
if you want feedback in a col, that is like a logging system. but you didn't say anything about the info you want in it.
You can close the thread. Solved it myself.
Please share your solution, for the benefit of others.
If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.
Ali
Enthusiastic self-taught user of MS Excel who's always learning!
Don't forget to say "thank you" in your thread to anyone who has offered you help. It's a universal courtesy.
You can reward them by clicking on * Add Reputation below their user name on the left, if you wish.
NB: as a Moderator, I never accept friendship requests.
Forum Rules (updated August 2023): please read them here.
Re: Move Files from current folder to a new subfolder specified in a column
Sub SortMoveFiles() Dim SourcePath As String Dim DestPath As String Dim FileName As String Dim LastRow As Long Dim i As Long '---------Write Header--------------------------- Range("K1").Select ActiveCell.FormulaR1C1 = ".PDF" Range("L1").Select ActiveCell.FormulaR1C1 = ".STP" Range("M1").Select ActiveCell.FormulaR1C1 = ".DXF" Range("N1").Select ActiveCell.FormulaR1C1 = ".STL" Dim folderPath As String Dim newfolderPath As String folderPath = Application.ActiveWorkbook.Path ' folderPath = Application.ThisWorkbook.Path '---------Create subfolders------------------------ On Error Resume Next MkDir folderPath & Application.PathSeparator & "Machining" MkDir folderPath & Application.PathSeparator & "3D Printing" MkDir folderPath & Application.PathSeparator & "Laser Cutting" '---------Copy PDF files to subfolders------------- LastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To LastRow newfolderPath = folderPath & Application.PathSeparator & Cells(i, "F") FileName = Cells(i, "A").Value & Cells(1, "K").Text If Right(folderPath, 1) <> Application.PathSeparator Then SourcePath = folderPath & Application.PathSeparator Else SourcePath = folderPath End If If Right(newfolderPath, 1) <> Application.PathSeparator Then DestPath = newfolderPath & Application.PathSeparator Else DestPath = newfolderPath End If If Dir(folderPath & Application.PathSeparator & FileName) = "" Then Cells(i, "K").Value = "Missing" ElseIf Dir(newfolderPath & FileName) <> "" Then Cells(i, "K").Value = "Already exists" Else Name folderPath & Application.PathSeparator & FileName As DestPath & FileName Cells(i, "K").Value = "Moved" End If Next i '---------Copy STP files to subfolders------------- LastRowz = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To LastRowz newfolderPath = folderPath & Application.PathSeparator & Cells(i, "F") FileName = Cells(i, "A").Value & Cells(1, "L").Text If Right(folderPath, 1) <> Application.PathSeparator Then SourcePath = folderPath & Application.PathSeparator Else SourcePath = folderPath End If If Right(newfolderPath, 1) <> Application.PathSeparator Then DestPath = newfolderPath & Application.PathSeparator Else DestPath = newfolderPath End If If Dir(folderPath & Application.PathSeparator & FileName) = "" Then Cells(i, "L").Value = "Missing" ElseIf Dir(newfolderPath & FileName) <> "" Then Cells(i, "L").Value = "Already exists" Else Name folderPath & Application.PathSeparator & FileName As DestPath & FileName Cells(i, "L").Value = "Moved" End If Next i '---------Copy DXF files to subfolders------------- LastRowz = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To LastRowz newfolderPath = folderPath & Application.PathSeparator & Cells(i, "F") FileName = Cells(i, "A").Value & Cells(1, "M").Text If Right(folderPath, 1) <> Application.PathSeparator Then SourcePath = folderPath & Application.PathSeparator Else SourcePath = folderPath End If If Right(newfolderPath, 1) <> Application.PathSeparator Then DestPath = newfolderPath & Application.PathSeparator Else DestPath = newfolderPath End If If Dir(folderPath & Application.PathSeparator & FileName) = "" Then Cells(i, "M").Value = "Missing" ElseIf Dir(newfolderPath & FileName) <> "" Then Cells(i, "M").Value = "Already exists" Else Name folderPath & Application.PathSeparator & FileName As DestPath & FileName Cells(i, "M").Value = "Moved" End If Next i '---------Copy STL files to subfolders------------- LastRowz = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To LastRowz newfolderPath = folderPath & Application.PathSeparator & Cells(i, "F") FileName = Cells(i, "A").Value & Cells(1, "N").Text If Right(folderPath, 1) <> Application.PathSeparator Then SourcePath = folderPath & Application.PathSeparator Else SourcePath = folderPath End If If Right(newfolderPath, 1) <> Application.PathSeparator Then DestPath = newfolderPath & Application.PathSeparator Else DestPath = newfolderPath End If If Dir(folderPath & Application.PathSeparator & FileName) = "" Then Cells(i, "N").Value = "Missing" ElseIf Dir(newfolderPath & FileName) <> "" Then Cells(i, "N").Value = "Already exists" Else Name folderPath & Application.PathSeparator & FileName As DestPath & FileName Cells(i, "N").Value = "Moved" End If Next i '---------Arrange & Condition last 4 columns------------- Columns("K:N").Select Selection.ColumnWidth = 9.29 '--- Columns("K:N").Select Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:="=""Missing""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font .Color = -16383844 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False '--- Columns("K:N").Select Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:="=""Moved""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font .Color = -16752384 .TintAndShade = 0 End With With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13561798 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False Range("K1").Select Cells.AutoFilter Rows("1:1").Select Selection.AutoFilter '---------------------Remove unwanted status----------- For i = 2 To LastRow If Cells(i, "F").Value = "Comercial" Then Cells(i, "K").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "Comercial" Then Cells(i, "L").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "Comercial" Then Cells(i, "M").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "Comercial" Then Cells(i, "N").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "Machining" Then Cells(i, "M").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "Machining" Then Cells(i, "N").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "Laser Cutting" Then Cells(i, "N").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "3D Printing" Then Cells(i, "K").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "3D Printing" Then Cells(i, "L").ClearContents End If Next i For i = 2 To LastRow If Cells(i, "F").Value = "3D Printing" Then Cells(i, "M").ClearContents End If Next i '---------------------Close Excel File----------------- Windows("Sort & Move Files.xlsm").Activate ActiveWindow.Close Application.DisplayAlerts = False End Sub
Last edited by zEKeBv; 12-31-2020 at 05:31 AM.
You can close it now !
Last edited by zEKeBv; 01-11-2021 at 03:43 PM.
As you still need help, it seems, I've removed the solved tag for now. Thanks for sharing.
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks