I want to move files to another folder from an Excel file (listfiles.xlsx) which contains paths of files in column A. The code below didn't work for me, can you help me please?
Sub movefile1()
Dim fso As FileSystemObject
Dim i As Long
Dim worksh As Worksheet
Dim workboo As Workbook
Set fso = CreateObject("scripting.filesystemobject")
Destination = "C:\Users\Desktop\Folder"
Set workboo = Workbooks.Open("C:\Users\TOSHIBA\Desktop\list_files.xlsx")
Set worksh = Worksheets("Listing")
numRows = worksh.Range("A" & Rows.Count).End(xlUp).Row
workboo.Windows(1).Visible = False
For i = 2 To numRows
Filepath = worksh.Range("A" & i).Value
fso.CopyFile Filepath, Destination
Next
End Sub
I changed the code but the fso.CopyFile Filepath, Destination does not work. They say permission refused
Place the line numRows = .Range("A" & .Rows.Count).End(xlUp).Row before the loop, otherwise the loop won't be executed at all
Related
I'm not good with VBA at all but I was curious to know if there is a way to count the amount of worksheets in a workbook that's looped for all the files in a folder.
For example, A1 list the file names and B1 shows the count of sheets.
A1 B1
book1 5
book2 6
currently have this code set up and need to adjust it
Sub ListAllFile()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = Worksheets.Add
Set objFolder = objFSO.GetFolder("W:\101g-19 (4.20.18) - Copy\")
ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
For Each objFile In objFolder.Files
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
'ADD A WORKSHEET AND PASTE "=SHEETS()" in A1 the copy value of a1 in to list
'close files with out saving
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Take a look at the below - note that you should run this from inside of a blank worksheet
Set CurrentWB = ActiveWorkbook
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim J As Long
Dim N As Long
Dim lc As Long
Dim lr As Long
'UPDATE FOLDER PATH OF WHERE XLS FILES ARE LOCATED
folderPath = "C:\Users\username\Desktop\test\" 'change to suit
J = 2
' Column Headers
CurrentWB.Sheets(1).Range("A1").Value = "Filename"
CurrentWB.Sheets(1).Range("B1").Value = "# of Sheets"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'YOU CAN CHANGE TO BE ANY FILE TYPE BUT CURRENTLY SET TO .XLSX
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set TempWB = Workbooks.Open(folderPath & Filename)
' Counts Per Worksheet
N = ActiveWorkbook.Worksheets.Count
CurrentWB.Sheets(1).Range("A" & J).Formula = Filename
CurrentWB.Sheets(1).Range("B" & J).Formula = N
' Close Temporary Workbook
TempWB.Close False
J = J + 1
Filename = Dir
Loop
In your for loop, open the file (assuming they are all excel here) and get the count of worksheets.
Something like:
For Each objFile In objFolder.Files
writeCell = ws.Cells(ws.UsedRange.Rows.Count + 1, 1)
writeCell.Value = objFile.Name
'ADD A WORKSHEET AND PASTE "=SHEETS()" in A1 the copy value of a1 in to list
'close files with out saving
Set wb = Workbooks.Open(objFile.Name)
writeCell.Offset(,1).value = wb.Worksheets.Count()
wb.Close(false)
Next
Sub ListallFiles()
Dim sFileName As String
Dim sFolderPath As String: sFolderPath = "C:\Temp\" ' Change folder path. Ensure that folder path ends with "\"
Dim oWB As Workbook
Dim oWS As Worksheet
' Get the first excel file name from specified folder
sFileName = Dir(sFolderPath & "*.xls*")
' Add a worksheet
Set oWS = ThisWorkbook.Worksheets.Add
With oWS
' Set folder name in the new sheet
.Range("A1").Value = "The file found in " & sFolderPath & " are:"
' Loop through all excel files in the specified folder
Do While Len(Trim(sFileName)) > 0
' Open workbook
Set oWB = Workbooks.Open(sFolderPath & sFileName)
' Set workbook details in the file
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Value = sFileName
.Range("B" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Value = oWB.Worksheets.Count
' Close workbook
oWB.Close False
' Clear workbook object
Set oWB = Nothing
' Get next excel file
sFileName = Dir()
Loop
End With
End Sub
Above UDF should open all files in the specified folder and give you the number of worksheets in each workbook on a new worksheet
I have the following VBA code meant to loop through a given folder and compile all files of a certain type into one single worksheet.
Sub cons_data()
Dim Master As Workbook
Dim sourceBook As Workbook
Dim sourceData As Worksheet
Dim CurrentFileName As String
Dim myPath As String
Dim LastRow As Long
Dim lRow As Long
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'The folder containing the files to be recap'd
myPath = "path"
'Finds the name of the first file of type .xls in the current directory
CurrentFileName = Dir(myPath & "\*.txt*")
'Create a workbook for the recap report
Set Master = ThisWorkbook
For i = 1 To Master.Worksheets.Count
With Master.Worksheets(i)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If lRow > 1 Then .Rows("2:" & lRow).ClearContents
End With
Next i
Do
Workbooks.Open (myPath & "\" & CurrentFileName)
Set sourceBook = Workbooks(CurrentFileName)
For i = 1 To sourceBook.Worksheets.Count
Set sourceData = sourceBook.Worksheets(i)
With sourceData
LastRow = Master.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Rows("2:" & lRow).Copy Master.Worksheets("Sheet1").Rows(LastRow + 1)
End With
Next i
sourceBook.Close
'Calling DIR w/o argument finds the next .txt file within the current directory.
CurrentFileName = Dir()
Loop While CurrentFileName <> ""
MsgBox "Done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This script works fine on certain file types, but for some reason when running it on a list of text files with a standard format (some of which are duplicates) it stops and presents the most recent entry it was working on in a separate Excel sheet. Is there any obvious reason looking at the code that this might be happening?
You need to kill old processes and discharge resources memory by adding after :
Set sourceBook = nothing
After
sourceBook.close
Hope this can help
Please help with the code for copying files one by one to the destination folder. I tried with "for Each loop but it is copying all the files at once to the destination folder. I am new to to vba and would be helpful if someone could crack the code for me. thanks in advance. here's the code i have managed to come up with.
I am getting run time error 53, File not found,e highlighting the below syntax.
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Sub Example1()
'Extracting file names Dim objFSO As Object Dim objFolder As Object Dim newobjFile As Object
Dim lastID As Long Dim myRRange As Range Dim Maxvalue As Integer
Dim sFolder As String Dim dFolder As String
Sub Example1()
'Extracting file names
Dim FSO
Dim objFolder As Object
Dim newobjFile As Object
Dim FromDir As String
Dim ToDir As String
Dim lastID As Long
Dim myRRange As Range
Dim Maxvalue As Integer
Dim Fname As String
FromDir = "C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\"
ToDir = "C:\Users\wazeer.ahamed\Documents\TcktIDfolder\"
Fname = Dir(FromDir)
If Len(FromDir) = 0 Then
MsgBox "No files"
Exit Sub
End If
Set myRange = Worksheets("Sheet1").Range("C:C")
Maxvalue = Application.WorksheetFunction.Max(myRange)
lastID = Maxvalue
'finding the next availabe row
erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Extracting file names
'Create an instance of the FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = FSO.GetFolder("C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro")
'loops through each file in the directory and prints their names and path
For Each newobjFile In objFolder.Files
'print file name
Cells(erow, 1) = Fname
'print file path
Cells(erow, 2) = newobjFile.Path
'PrintUniqueID
Cells(erow, 3) = lastID + 1
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Cells(erow, 5) = "file succesfully copied"
Next newobjFile
Set FSO = Nothing
Set newobjFile = Nothing
Set objFolder = Nothing
End Sub
I think that the code can be more simple and dynamic if you play with your own excel file.
Use "A1" range to put the source folder.
Use "B:B" range to put the
name of the files.
Use "C:C" range to concatenate the previous
columns.
Use "D1" range to put the destination folder.
Sub copyFiles()
'Macro for copy files
'Set variable
Dim source As String
Dim destination As String
Dim x As Integer
Dim destinationNumber As Integer
destinationNumber = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("C:C"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create the folder if not exist
If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1"), 16) = "" Then
MkDir ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1")
End If
'Run the loop to copy all the files
For x = 1 To destinationNumber
source = ThisWorkbook.Sheets("Sheet1").Range("C" & x)
destination = ThisWorkbook.Sheets("Sheet1").Range("D1")
FileCopy source, destination
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With this you can change the folders' paths and file names whenever you want. I've used FileCopy to preserve your files in the source but if you need to delete it's better use other method.
I have this code that gets the filenames on the selected directories.
Sub browsefile()
Dim file As Variant
Dim i As Integer
Dim lRow As Long
Set main = ThisWorkbook.Sheets("Main")
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
For i = 1 To UBound(file)
lRow = Cells(Rows.Count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i)))
Next i
End Sub
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Once I've selected the files, I have to put it in Column O. I have tried using .FullName but is not applicable in this area or maybe I've just misused it. Then later this will be send as attached file in an email in outlook.
By the way, I've got some of its code here.
Any help?
In Outlook include attachments with Attachments.Add
Private Sub browsefile_Att()
' Multiselect = False so file is not an array
' Dim file As Variant
Dim file As String
Dim lRow As Long
Dim main As Worksheet
Dim olOlk As Object
Dim olNewmail As Object
Set main = ThisWorkbook.Sheets("Main")
' Multiselect = False so file is not an array
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , False)
lRow = Cells(Rows.Count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = file
Set olOlk = CreateObject("Outlook.Application")
Set olNewmail = olOlk.CreateItem(olMailItem)
olNewmail.Attachments.Add file
olNewmail.Display
ExitRoutine:
Set olNewmail = Nothing
Set olOlk = Nothing
End Sub
I assume you are trying to obtain the full path to the file that you have selected. Application.GetOpenFilename already returns you that and hence, there is no need to reprocess your file with GetFileName function?
Changing
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i)))
To
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
should work assuming i have understood your question correctly. Hope this helps!
I have Multiple files in a folder.i wants to copy all Files data (i.e.all columns to new sheet) to one new sheet.
E.g. file 1 Contains 5 columns of data and file 2 contains 10 columns of data and so on. this data should copy on new sheet like first 5 columns are from file 1 and then on the same sheet from column 6, the file2 data should be copy and so on.
i tried but facing some problems like i am able to copy first file data successfully but when i am going to second file , second file data is overwriting on first file. i want second file data to the next column.
Below is my code
Public Sub CommandButton1_Click()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim mainwb As Workbook
Dim ws As Worksheet
Dim search_result As Range 'range search result
Dim blank_cell As Long
Dim wb As Workbook
Path = "C:\Test\"
Filename = Dir(Path & "*.xls")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
Set wbk = ActiveWorkbook
sheetname = ActiveSheet.Name
wbk.Sheets(sheetname).Activate
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To Lastrow
wbk.Sheets(sheetname).UsedRange.Copy
Workbooks("aaa.xlsm").Activate
Set wb = ActiveWorkbook
sheetname1 = ActiveSheet.Name
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
wb.Sheets(sheetname1).Range("A1").Select
wb.Sheets(sheetname1).Paste
Next i
ActiveCell.Offset(0, 1).Select
wbk.Close SaveChanges:=False
Filename = Dir
Loop
End Sub
plz help me......
Thanks in Advance
With the For i = 1 To Lastrow loop you are pasting the content several times and I was unable to correct it without significant change. As a result may I recommend using the below sample, I have added comments to describe what is happening.
Public Sub Sample()
Dim Fl As Object
Dim Fldr As Object
Dim FSO As Object
Dim LngColumn As Long
Dim WkBk_Dest As Excel.Workbook
Dim WkBk_Src As Excel.Workbook
Dim WkSht_Dest As Excel.Worksheet
Dim WkSht_Src As Excel.Worksheet
'Using FileSystemObject to get the folder of files
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fldr = FSO.GetFolder("C:\Users\Gary\Desktop\New folder\")
'Setting a reference to the destination worksheet (i.e. where the
'data we are collecting is going to)
Set WkBk_Dest = ThisWorkbook
Set WkSht_Dest = WkBk_Dest.Worksheets("Sheet1")
'Look at each file in the folder
For Each Fl In Fldr.Files
'Is it a xls, xlsx, xlsm, etc...
If InStr(1, Right(Fl.Name, 5), ".xls") <> 0 Then
'Get the next free column in our destination
LngColumn = WkSht_Dest.Cells(1, WkSht_Dest.Columns.Count).End(xlToLeft).Column
If LngColumn > 1 Then LngColumn = LngColumn + 1
'Set a reference to the source (note in this case it is simply selected the first worksheet
Set WkBk_Src = Application.Workbooks.Open(Fl.Path)
Set WkSht_Src = WkBk_Src.Worksheets(1)
'Copy the data from source to destination
WkSht_Src.UsedRange.Copy WkSht_Dest.Cells(1, LngColumn)
Set WkSht_Src = Nothing
WkBk_Src.Close 0
Set WkBk_Src = Nothing
End If
Next
Set WkSht_Dest = Nothing
Set WkBk_Dest = Nothing
Set Fldr = Nothing
Set FSO = Nothing
End Sub