I want the code below to use 2 methods. the first method is copy file and the second method is move file. For method 1 I did a comment so that to do method 2 but it didn't work there was an error.
Sub movecopyFiles()
Dim sh As Worksheet, lastR As Long, arrA, i As Long, k As Long
Dim fileD As FileDialog, strDestFold As String, FSO As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row ' last row on A:A column
arrA = sh.Range("A2:E" & lastR).Value2 'place the range in an array for faster iteration
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the destination folder!"
.AllowMultiSelect = False
If .Show = -1 Then
strDestFold = .SelectedItems.Item(1) & "\" 'select the destination folder
End If
End With
If strDestFold = "" Then Exit Sub 'in case of not selecting any folder
For i = 1 To UBound(arrA)
If UCase(arrA(i, 5)) = "V" Then 'copy the file only if a "V" exists in column E:E
If FSO.FileExists(arrA(i, 1)) Then 'check if the path in excel is correct
' FSO.COPYFILE arrA(i, 1), strDestFold, True 'copy the file (True, to overwrite the file if it exists)
FSO.moveFILE arrA(i, 1), strDestFold, True 'move the file (True, to overwrite the file if it exists) >> error this line
k = k + 1
Else
MsgBox arrA(i, 1) & " file could not be found." & vbCrLf & _
"Please, check the spelling and correct the file full path!", vbInformation, _
"File does not exist..."
End If
End If
Next i
MsgBox "Copied " & k & " files in " & strDestFold, , "Ready..."
End Sub
Please, adapt the following part in this way:
Dim fileName As String 'new variable to be declared
'your existing code...
If FSO.FileExists(arrA(i, 1)) Then 'check if the path in excel is correct
fileName = Right(arrA(i, 1), Len(arrA(i, 1)) - InStrRev(arrA(i, 1), "\"))
If FSO.FileExists(strDestFold & fileName) Then Kill strDestFold & fileName 'delete file if exists
FSO.MoveFile arrA(i, 1), strDestFold 'move the file
k = k + 1
Else
MsgBox arrA(i, 1) & " file could not be found." & vbCrLf & _
"Please, check the spelling and correct the file full path!", vbInformation, _
"File does not exist..."
End If
'your existing code
Related
Can anyone please help me update the below VBA Code which I found in the below website, I changed the MyPath to loop through the rows but somehow it only merged the first folder in loop and it is not merging the next folder in the given rows.
http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X/page3
Option Explicit
Sub Main()
Dim DestFile As String ' <-- change to suit
Dim MyPath As String, MyFiles As String
Dim a() As String, i, j, numRows As Long, f As String
' Choose the folder or just replace that part by: MyPath = Range("E3")
'With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
'.AllowMultiSelect = False
' If .Show = False Then Exit Sub
'MyPath = .SelectedItems(1)
' DoEvents
'End With
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Worksheets("ForProcessing")
numRows = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For j = 5 To numRows
MyPath = ws.Cells(j, 1).Value
DestFile = ws.Cells(j, 2).Value & " Rev " & ws.Cells(j, 6).Value & ".pdf"
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
ReDim a(1 To 2 ^ 14)
f = Dir(MyPath & "*.pdf")
While Len(f)
If StrComp(f, DestFile, vbTextCompare) Then
i = i + 1
a(i) = f
End If
f = Dir()
Wend
' Merge PDFs
If i Then
ReDim Preserve a(1 To i)
MyFiles = Join(a, ",")
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, DestFile)
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
Next j
End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
' Reference required: VBE - Tools - References - Acrobat
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
I'm getting the first pdf combined as per the code, however, when it reads the next row this code
MyFiles = Join(a, ",")
The MyFiles value is having two comma before the set of PDF files that needed to be merged like this >>> ",,name1.pdf,name2.pdf"
If anyone can help me update this code will very much appreciated.
Thanks,
Mielkew
I am a beginner in Excel VBA but I would like to create a file where I can select certain worksheets by means of a userform with checkboxes. In principle, it is then intended that only the check boxes where the value is true should be exported.
Below I have 2 codes that work well separately from each other but I have not yet been able to get them to work together.
Note: both codes come from the internet.
If possible I would like to write a loop to keep the overview.
the code to export sheets as pdf and put them in a outlook
Sub Saveaspdfandsend1()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
Else
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
the other code i tried I can see which checkbox is checked unfortunately I can't rewrite it so only the checked boxes will be exported to pdf.
Private Sub CommandButton100_Click()
For i = 100 To 113
If UserForm2.Controls("CheckBox" & i).Value = True Then
a = a + 1
End If
Next i
k = 1
For i = 100 To 113
If UserForm2.Controls("CheckBox" & i).Value = True And a = 1 Then
b = UserForm2.Controls("CheckBox" & i).Caption & "."
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k <> a Then
b = b & UserForm2.Controls("CheckBox" & i).Caption & ", "
k = k + 1
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k = a Then
b = b & "and " & UserForm2.Controls("CheckBox" & i).Caption & "."
End If
Next i
MsgBox ("You have selected " & b)
End Sub
Can someone help me please I am struggling for some time now?
Please, try the next function:
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
It will return an array composed from the ticked check boxes caption.
It can be used demonstratively, in this way:
Sub testSheetsArrFunction()
Debug.Print Join(sheetsArr(UserForm2), ",")
End Sub
The above code will return in Immediate Window a string containing the checked check boxes caption (separated by comma). It may be run from a standard module, too. Of course, the function must be copied in that module. And the form to be loaded, having some check boxes ticked.
Now, you have to change a single code line in your (working) code:
Replace:
xArrShetts = Array("test", "Sheet1", "Sheet2")
with:
xArrShetts = sheetsArr(UserForm2)
It should use the array built in the above function. Of course the function have to be copied in the module where to be called. If placed in the form code module, it can be simple called as:
xArrShetts = sheetsArr(Me)
Edited:
You should only paste the next code in the form code module and show the form:
Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
I am using this to try and copy photos that exist in the list within a list in excel. it seems check but doesn't see anything in the source folder and returns the "Does N" from the code below. I have enabled macros and the folders don't see locked. any help would be much appriciated
Option Explicit
Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim bContinue As Boolean
bContinue = True
iRow = 1
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "C:\Users\username\Desktop\source\"
sDestinationPath = "C:\Users\username\Desktop\TARGET\"
sFileType = ".jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
' LOOP THROUGH COLUMN "A" TO PICK THE FILES.
While bContinue
If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Process executed" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.
If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("B" & CStr(iRow)).Value = "Does N"
Range("B" & CStr(iRow)).Font.Bold = True
Else
Range("B" & CStr(iRow)).Value = "On Hand"
Range("B" & CStr(iRow)).Font.Bold = False
If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")
' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If
'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
You shouldn’t be creating a new FileSystemObject on every iteration. Also, the destination folder can only be checked once - no need to check it every time.
See below your code with a few changes.
Option Explicit
Sub CopyFiles()
On Error GoTo Errproc
Const sSourcePath As String = "C:\Users\username\Desktop\source\"
Const sDestinationPath As String = "C:\Users\username\Desktop\TARGET\"
Const sFileType As String = ".jpg"
'validate destination folder
If Len(Dir(sDestinationPath)) = 0 Then
MsgBox "Destination path does not exist..."
Exit Sub
End If
Dim iRow As Integer
iRow = Range("A" & Rows.Count).End(xlUp).Row
Dim rr As Range, r As Range
Set rr = Range("A1:A" & iRow)
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each r In rr
With objFSO
If Not .FileExists(sSourcePath & r.Value & sFileType) Then
r.Offset(0, 1).Value = "Does N"
r.Offset(0, 1).Font.Bold = True
Else
r.Offset(0, 1).Value = "On Hand"
r.Offset(0, 1).Font.Bold = False
objFSO.CopyFile sSourcePath & r.Value & sFileType, sDestinationPath, True 'Overwrite
'objFSO.MoveFile Source:=sSourcePath & r.Value & sFileType , Destination:=sDestinationPath
End If
End With
Next r
Leave:
Set objFSO = Nothing
On Error GoTo 0
Exit Sub
Errproc:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
I have a VBA for copying images from one folder to another based on image names. You can check macro in work in attached. Code is:
Option Explicit
Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim bContinue As Boolean
bContinue = True
iRow = 2
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
sFileType = ".jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
' LOOP THROUGH COLUMN "A" TO PICK THE FILES.
While bContinue
If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Images have been moved. Thank you!" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.
If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("B" & CStr(iRow)).Value = "Does Not Exists"
Range("B" & CStr(iRow)).Font.Bold = True
Else
Range("B" & CStr(iRow)).Value = "On Hand"
Range("B" & CStr(iRow)).Font.Bold = False
If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")
' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If
'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
However, I need 2 more things to add to this code:
When I enter the name of the file to be copied, I also want to copy
files that have the same name PLUS extension _01/_02/.../_07 if
those exist.
I want macro to look not only inside specified folder but also in
subfolders inside the folder and subfolders inside the subfolder
etc.
Can anyone help?
Thanks!
What you need is some Recursive Subs to find all the similar filenames based on the Range value.
Here I will approach this goal with below code with a couple of steps:
For each Range value (stored as a Key in Dictionary), find all the file names (exact and similar as Item in Dictionary). Joining each finding with "|" (an illegal file name character).
Process the Dictionary items after all files and sub folders from Source Path
For each Item in the dictionary of a key, see if existing file in destination folder. Append " (i)" to destination file name if already exists.
Copy the destination file to destination folder.
While copying, it returns the
Stop looping when first Empty cell is encountered
NOTE: Code not been tested, only compiled fine
Option Explicit
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
Private Const sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
Private Const sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
Private Const sFileType = "jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
Private Const DIV = "|" ' A character that's not legal file name
Private objFSO As Object, objDict As Object
Sub CopyFilesAlike()
Dim lRow As Long, sName As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(sSourcePath) Then
MsgBox "Source folder not found!" & vbCrLf & sSourcePath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
If Not objFSO.FolderExists(sDestinationPath) Then
MsgBox "Destination folder not found!" & vbCrLf & sDestinationPath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
' Proceed when both Source and Destination folders found
Set objDict = CreateObject("Scripting.Dictionary")
lRow = 2
Do Until IsEmpty(Cells(lRow, "A")) ' Stop on first empty cell in Column A from lRow
' Get Main file name to look up
sName = Cells(lRow, "A").Value
' Look for files (exact and alikes from sub folders) to add to dictionary
LookForFilesAlike sName, objFSO.GetFolder(sSourcePath)
' Copy files
If objDict.Count = 0 Then
Cells(lRow, "B").Value = "No files found."
Else
Cells(lRow, "B").Value = objDict.Count & " filenames(s) found." & vbLf & CopyFiles
End If
' Clear the Dictionary for next Name
objDict.RemoveAll
' Increment row counter
lRow = lRow + 1
Loop
Set objDict = Nothing
I_AM_DONE:
Set objFSO = Nothing
End Sub
Private Sub LookForFilesAlike(ByVal sName As String, ByVal objFDR As Object)
Dim oFile As Object, oFDR As Object
' Add files of current folder to dictionary if name matches
For Each oFile In objFDR.Files
If InStr(1, oFile.Name, sName, vbTextCompare) = 1 Then ' Names beginning with sName
' Check the extension to match
If LCase(objFSO.GetExtensionName(oFile)) = LCase(sFileType) Then
If objDict.Exists(oFile.Name) Then
' Append Path to existing entry
objDict.Item(oFile.Name) = objDict.Item(oFile.Name) & DIV & oFile.Path
Else
' Add Key and current path
objDict.Add oFile.Name, oFile.Path
End If
End If
End If
Next
' Recurse into each sub folder
For Each oFDR In objFDR.SubFolders
LookForFilesAlike sName, oFDR
Next
End Sub
Private Function CopyFiles() As String
Dim i As Long, oKeys As Variant, oItem As Variant, iRepeat As Integer, sName As String, sOut As String
sOut = ""
' Process the items for each key in Dictionary
Set oKeys = objDict.Keys ' <- Add "Set " before oKeys
For i = 0 To objDict.Count
For Each oItem In Split(objDict.Item(oKeys(i)), DIV)
' Determine the filename in destination path
If objFSO.FileExists(sDestinationPath & objFSO.GetFileName(oItem)) Then
' Same file name alreay found, try append " (i)"
iRepeat = 0
Do
iRepeat = iRepeat + 1
sName = objFSO.GetBaseName(oItem) & " (" & iRepeat & ")" & objFSO.GetExtensionName(oItem)
Loop While objFSO.FileExists(sDestinationPath & sName)
sName = sDestinationPath & sName
Else
' First file to be copied to destination folder
sName = sDestinationPath
End If
' Copy the source file to destination file
If Len(sOut) = 0 Then
sOut = oItem & DIV & sName
Else
sOut = sOut & vbLf & oItem & DIV & sName
End If
objFSO.CopyFile oItem, sName
Next
Next
CopyFiles = sOut
End Function
I have to copy data from multiple excel files named with numbers (1.xlsx, 2.xlsx, 3.xlsx, etc). I wrote this macro. It runs. But no copy happens, the main workbook in which I ran the macro remains empty.
Sub filecopy()
' The macro is running in the main file, which I saved as .xlsm
' This main.xlsm is in the same folder as the files from which I copy the data
Dim Filename As String, Pathname As String,xx as Double
Activesheet.Usedrange.Clear 'I delete the current contents of the sheet
Pathname = ActiveWorkbook.Path
Filename = Dir(Pathname & "*.xlsx")
xx = 1 'the first column where the contents of the first file goes
Do While Len(Filename) > 0
Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1"
Cells(2, xx).Formula = "='[" & Filename & "]Sheet1'!B2"
Cells(3, xx).Formula = "='[" & Filename & "]Sheet1'!C3"
xx = xx + 1 'next file next column
Filename = Dir()
Loop
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'every formula goes to value
MsgBox "Work Complete", vbInformation
End Sub
There are 2 errors in your code:
1. \ is missing -> filename is empty
Replace Filename = Dir(Pathname & "*.xlsx") with Filename = Dir(Pathname & "\*.xlsx")
2. the formula is not correct -> not complete filename
Change your formulas e.g. Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1" with this Cells(1, xx).Formula = "='" & Pathname & "\[" & Filename & "]Sheet1'!A1"
What about a solution like this:
Pathname = ActiveWorkbook.Path 'Be sure is the rigth path
Filename = Dir(Pathname & "\*.xlsx") 'I've addedd a "\"
xx = 1
Do While Len(Filename) > 0
If Filename <> ThisWorkbook.Name Then
Set mFile = Workbooks.Open(Pathname & "\" & Filename)
Else
GoTo NextFile
End If
With mFile.ActiveSheet 'Use the sheet you need here
Cells(1, xx) = .Cells(1, 1).Value
Cells(2, xx) = .Cells(2, 1).Value
Cells(3, xx) = .Cells(3, 1).Value
End With
xx = xx + 1 'next file next column
Application.DisplayAlerts = False
mFile.Close savechanges:=False
Application.DisplayAlerts = True
Set mFile = Nothing
NextFile:
Filename = Dir()
Loop