I have written code which reads file names from column A and renames it to column B, if file specified in column A exists in Input folder.
Sub Rename_click()
Dim inputFolder$, iFile$, oFile$
Dim iRow&, lRow&
inputFolder = ThisWorkbook.Path & Application.PathSeparator & "Input"
With shInput
If .FilterMode Then .ShowAllData
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = 2 To lRow
iFile = .Cells(iRow, "A")
oFile = .Cells(iRow, "B")
If iFile <> "" And oFile <> "" Then
If Dir(inputFolder & Application.PathSeparator & iFile) <> "" Then
Name inputFolder & Application.PathSeparator & iFile As inputFolder & Application.PathSeparator & oFile
End If
End If
Next
End With
End Sub
It works in Windows. How can I make it Mac compatible?
Related
Below mentioned code successfully copies the file based on source names mentioned in excel sheet using moveFilesFromListPartial, it works perfectly well. i just need one change in the code.
e.g. in excel sheet a source name is written as "Robert Anderson" However if a file with incorrect spelling like "Robert Andersonn" or "Robertt Anderson" comes into source folder, these file with incorrect spelling should get copy in another folder (e.g. Error Folder). In other words files whose exact source name is not in excel sheet should get copy to another folder rather than the destination folder. This way at the end of day we can identify which file names have spelling mistakes and we can simply correct them without reviewing all the files.
currently these kind of files remain stuck in source folder and because of incorrect file name they do not get copy, and i have added another macro which after some times moved the file from Source folder to Archive folder.
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source"
Const dPath As String = "E:\Uploading\Destination"
Const fRow As Long = 2
Const Col As String = "B", colExt As String = "C"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
Dim sExt As String 'extension (dot inclusive)
For r = fRow To lRow
sPartialFileName = CStr(ws.Cells(r, Col).Value)
sExt = CStr(ws.Cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount + 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount + 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount + 1
End If
sFileName = Dir
Loop
Else ' the cell is blank
BlanksCount = BlanksCount + 1
End If
Next r
End Sub
Another Code which I run after copying the file to Destination folder which moves the files from Source to Archive folder.
Sub moveAllFilesInDateFolderIfNotExist()
Dim DateFold As String, fileName As String, objFSO As Object
Const sFolderPath As String = "E:\Uploading\Source"
Const dFolderPath As String = "E:\Uploading\Archive"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' create the folder
if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
If Not objFSO.FileExists(DateFold & "\" & fileName) Then
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
Else
Kill DateFold & "\" & fileName
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
End If
fileName = Dir
Loop
End Sub
Please, use the next updated (your macro):
Sub AddMissingItems()
Dim Dic As Object, arr() As Variant, outArr() As Variant
Dim i As Long, k As Long, iRow As Long, c As Long
Dim r As Long, j As Long
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Sheet1")
arr = .Range("A1:A" & .Range("A" & .rows.count).End(xlUp).row).Value
For i = 1 To UBound(arr, 1)
If Dic.Exists(arr(i, 1)) = False Then
Dic.Add (arr(i, 1)), ""
End If
Next
End With
With Workbooks("ExtractFile.xlsx").Worksheets("Sheet1")
c = .cells(1, Columns.count).End(xlToLeft).column
r = .Range("A" & .rows.count).End(xlUp).row 'calculate the last row in A:A, too
arr = .Range("A1", .cells(r, c)).Value 'place in the array all existing columns
ReDim outArr(1 To UBound(arr), 1 To c) 'extend the redimmed array to all columns
For i = 1 To UBound(arr)
If Dic.Exists(arr(i, 1)) = False Then
k = k + 1
For j = 1 To c 'iterate between all array columns:
outArr(k, j) = arr(i, j) 'place the value from each column
Next j
End If
Next
End With
iRow = Sheets("Sheet1").Range("A" & rows.count).End(3).row + 1
If k <> 0 Then
Sheets("Sheet1").Range("A" & iRow).Resize(k, UBound(arr, 2)).Value = outArr 'resize by columns, too
k = 0
End If
End Sub
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source", dPath As String = "E:\Uploading\Destination"
Const Col As String = "B", colExt As String = "C"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
Dim lRow As Long: lRow = ws.cells(ws.rows.count, Col).End(xlUp).row
' Validate the last row.
If lRow < 2 Then MsgBox "No data in column range.", vbCritical: Exit Sub
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath & "' doesn't exist.", vbCritical: Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath & "' doesn't exist.", vbCritical: Exit Sub
End If
Dim r As Long, sFilePath As String, sPartialFileName As String, sFileName As String
Dim dFilePath As String, sExt As String 'extension (dot inclusive)
'_________________________________________________________________________________
Dim arrC, k As Long 'an array to keep the copied fileNames and a variable to keep
'the next array element to be loaded
Dim objFolder As Object: Set objFolder = fso.GetFolder(sPath)
ReDim arrC(objFolder.files.count) 'redim the array at the number of total files
'_________________________________________________________________________________
For r = 2 To lRow
sPartialFileName = CStr(ws.cells(r, Col).Value)
sExt = CStr(ws.cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the destination file...
fso.CopyFile sFilePath, dFilePath ' ... if doesn't exist...
'________________________________________________________________________
arrC(k) = sFileName: k = k + 1 'each copied file name is loaded in the array
'________________________________________________________________________
Else
'______________________________________________________________________
arrC(k) = sFileName: k = k + 1 'each copied file name is loaded in the array
'________________________________________________________________________
End If
End If
sFileName = Dir
Loop
End If
Next r
'__________________________________________________________________________________
If k > 0 Then ReDim Preserve arrC(k - 1) 'keep in the array only loaded elements
moveReminedFiles sPath, arrC
'_________________________________________________________________________________
End Sub
All modifications are between '_______________ lines
Copy the next Sub, which is called by the above one, in the same module:
Sub moveReminedFiles(sFolder As String, arr)
Dim fileName As String, mtch
Const destFolder As String = "E:\Uploading\Error Files\" 'use here your folder where errored files to be moved
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
fileName = Dir(sFolder & "*.*")
Do While fileName <> ""
mtch = Application.match(fileName, arr, 0) 'if the file name does not exist in the array:
If IsError(mtch) Then Name sFolder & fileName As destFolder & fileName 'move it
fileName = Dir
Loop
End Sub
Please, test it and send some feedback. Of course, the bushy code could not be tested...
Edited:
Please, try the next updated (former) Sub which comes after the above code, moving all files in the Archive folder. Now, it should also do what you required in this question. Since it is not tested, you should send some feedback after testing it:
Sub moveAllFilesInDateFolderIfNotExist(sFolderPath As String, arr)
Dim DateFold As String, fileName As String, objFSO As Object, mtch
Const dFolderPath As String = "E:\Uploading\Archive\"
Const errFolder As String = "E:\Uploading\Error Files\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") & "\" ' create the cur date folder name
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold 'create the necessary folder if it does not exist
fileName = Dir(sFolderPath & "\*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
mtch = Application.match(fileName, arr, 0)
If IsError(mtch) Then 'if the file name does not exist in the array:
If objFSO.FileExists(errFolder & "\" & fileName) Then
Kill errFolder & fileName
End If
Name sFolderPath & fileName As errFolder & fileName 'move it
Else
If Not objFSO.FileExists(DateFold & "\" & fileName) Then
Name sFolderPath & fileName As DateFold & fileName
Else
Kill DateFold & fileName
Name sFolderPath & fileName As DateFold & fileName
End If
End If
fileName = Dir
Loop
End Sub
You only have to change moveReminedFiles sPath, arrC with moveAllFilesInDateFolderIfNotExist sPath, arrC and run it. Take care that now it will also move the files in the archive folder. Of course, except the wrong spelled ones which will be moved in their special Error folder...
Please, send some feedback after testing it.
I'm having an issue with my code:
Sub lalalala ()
Dim s5 As Worksheet
Set s5 = ThisWorkbook.Sheets("Test")
Dim DesktopPath As String
Dim DesktopPathMAIN As String
Dim DesktopPathSUB As String
Dim file As String
Dim sfile As String
Dim sDFolder As String
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
DesktopPath = Environ("USERPROFILE") & "\Desktop\"
DesktopPathMAIN = DesktopPath & "THE FINAL TEST"
If Dir(DesktopPathMAIN, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & DesktopPathMAIN & """")
End If
lastrow = s5.Range("B" & s5.Rows.Count).End(xlUp).Row
Set rng = s5.Range("B1:B" & lastrow)
For Each c In rng
If Dir(DesktopPathMAIN & "\" & c.Offset(, 5).Value, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & DesktopPathMAIN & "\" & c.Offset(, 5).Value & """")
End If
Next c
lastrow = s5.Range("G" & s5.Rows.Count).End(xlUp).Row
Set rng = s5.Range("G1:G" & lastrow)
For Each c In rng
sDFolder = DesktopPathMAIN & "\" & c.Value & "\"
sfile = s5.Range("H1").Value & c.Offset(, -2).Value
Call oFSO.CopyFile(sfile, sDFolder)
Next c
End Sub
When i run the macro it causes error code 76, but if i run again it works perfectly. I realized it happens when the cell changes the value of the destination folder at this line sfile = s5.Range("H1").Value & c.Offset(, -2).Value.
But it only happens 1 time, if i run again it works perfectly.
How can i fix that?
thank you
I am trying the combine the all workbooks from a folder after some changes into on one new workbook, each workbook has only one sheet. But my code is not woking at following line:
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Could you please check what is causing the error?
Sub CombineIDBISheet()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim wksCurSheet As Worksheet
Dim wbkCurBook As Workbook
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Set wbkCurBook = ActiveWorkbook
If Range("B4") = "Search Criteria" Then
Cells.WrapText = False
Cells.UnMerge
Dim x
With Range("d7", Range("d" & Rows.Count).End(xlUp))
x = .Address
.Value = Evaluate("index(date(mid(" & x & ",7,4),mid(" & x & ",4,2),left(" & x & ",2))+timevalue(right(" & x & ",8)),,)")
.NumberFormat = "dd/mm/yyyy hh:mm:ss"
With .Offset(, 1)
.TextToColumns .Cells(1), 1, FieldInfo:=Array(1, 4)
.NumberFormat = "dd/mm/yyyy"
End With
End With
With Range("j7:k" & Cells(Rows.Count, 4).End(xlUp).Row)
.Value = .Value
.UnMerge
End With
Range("b3:b5").Copy Range("c3:c5")
Columns("a:b").EntireColumn.Delete
Columns("i").EntireColumn.AutoFit
Columns("L:p").EntireColumn.Delete
Else
End If
Range("B4").ClearContents
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
ActiveWorkbook.Close SaveChanges:=True
End With
xFileName = Dir
Loop
End If
End Sub
I have the following code which is supposed to list all excel files in a folder.
Code:
Sub List()
'On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim i2 As Long
Dim i3 As Long
Dim j2 As Long
Dim name As String
Dim Txt As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(ThisWorkbook.Worksheets(1).Range("M4").value)
i = 18
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.files
'print file path
ThisWorkbook.Worksheets(1).Cells(i, 6) = objFile.path
'print file path
ThisWorkbook.Worksheets(1).Cells(i, 7) = Replace(objFile.name, ".xlsx", "")
'print file removal icon
ThisWorkbook.Worksheets(1).Cells(i, 30) = "Remove"
'Add Hyperlink
ThisWorkbook.Worksheets(1).Hyperlinks.Add Anchor:=Cells(i, 27), Address:=objFile.path, TextToDisplay:="Open Announcement"
'Lookup contact info
ThisWorkbook.Worksheets(1).Cells(i, 11).Formula = "=IFERROR(INDEX(Contacts!$C:$C,MATCH(""*"" & """ & Range("G" & i).value & """ & ""*"",Contacts!$B:$B,0)),IFERROR(INDEX(Contacts!$C:$C,MATCH(""" & Left(Range("G" & i).value, 7) & """ & ""*"",Contacts!$B:$B,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 14).Formula = "=IF(""" & Range("K" & i).value & """ = """","""",IFERROR(INDEX(Contacts!$D:$D,MATCH(""*"" & """ & Range("K" & i).value & """ & ""*"",Contacts!$C:$C,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 18).Formula = "=IF(""" & Range("K" & i).value & """ = """","""",IFERROR(INDEX(Contacts!$E:$E,MATCH(""*"" & """ & Range("K" & i).value & """ & ""*"",Contacts!$C:$C,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 23) = "=IF(K" & i & "="""",""Missing Contact! "","""")&IF(INDEX(Data!L:L,MATCH(G" & i & ",Data!F:F,0))=""TBC"",""Missing Data! "","""")&IF(U" & i & ">=DATE(2017,1,1),"""",""Check Date!"")"
'Delivery Dates
ThisWorkbook.Worksheets(1).Cells(i, 21).Formula = "=IFERROR(INDEX(Data!$Q:$Q,MATCH(""*"" & """ & Range("G" & i).value & """ & ""*"",Data!$F:$F,0)),IFERROR(INDEX(Data!$Q:$Q,MATCH(""*"" & """ & Left(Range("G" & i).value, 7) & """ & ""*"",Data!$F:$F,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 25) = "Sync"
i = i + 1
Next objFile
ThisWorkbook.Worksheets(1).Calculate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
For some reason, despite there being several excel files in the folder, only one file is being listed.
Please can someone show me where i am going wrong?
Start with something simple and then make it more and more complicated. The following works for me, displaying all the files you have in the folder. They are printed in the immediate window (Ctrl+G) in the Visual Basic Editor. From there, you can go further:
Option Explicit
Sub List()
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Long
Dim i2 As Long
Dim i3 As Long
Dim j2 As Long
Dim name As String
Dim Txt As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\TestMe\Arch")
For Each objFile In objFolder.Files
Debug.Print objFile
Next objFile
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
I am looking for help with VBA to find file names listed in an excel Column A from a folder and return the file path in Column B
The code below works, however if I would like excel to skip the row if the filename cannot be found so that the filepath results are returned in the cell directly next to the filename.
Private Sub CommandButton1_Click()
Dim sh As Worksheet, rng As Range, lr As Long, fPath As String
Set sh = Sheets(1) 'Change to actual
lstRw = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlWhole, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
Set rng = sh.Range("A2:A" & lstRw)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
fwb = Dir(fPath & "*.*")
x = 2
Do While fwb <> ""
For Each c In rng
If InStr(LCase(fwb), LCase(c.Value)) > 0 Then
Worksheets("Sheet2").Range("A" & x) = fwb
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(fPath & fwb)
Worksheets("Sheet1").Range("B" & x) = f.Path
Set fs = Nothing
Set f = Nothing
x = x + 1
End If
Next
fwb = Dir
Loop
Set sh = Nothing
Set rng = Nothing
Sheets(2).Activate
End Sub
As mentioned in my comments above, use the DIR inside the range loop. See this example.
Here it won't output anything to Col B if the respective cell in Col A doesn't return anything.
Sub Sample()
Dim sh As Worksheet
Dim rng As Range
Dim i As Long, Lrow As Long
Dim fPath As String, sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
Set sh = ThisWorkbook.Sheets("Sheet1")
With sh
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
'~~> Check for partial match
sPath = fPath & "*" & .Range("A" & i).Value & "*.*"
If Len(Trim(Dir(sPath))) > 0 Then
.Range("B" & i).Value = Dir(sPath)
End If
Next i
End With
End Sub
Note: If you do not want a partial match then consider revising
sPath = fPath & "*" & .Range("A" & i).Value & "*.*"
to
sPath = fPath & .Range("A" & i).Value & ".*"