I have written an Excel macro to copy pdf files from a source folder to a destination folder. I am now trying to incorporate a Do Loop into the macro so I can move multiple files, each of which are identified in a separate cell. Also, the quantity of files to be moved will vary.
When I use the command line
sFile = Range("G14").Value & ".pdf"
it does copy the file listed in cell G14 to the destination folder. However, I am having no luck using the Do Loop and sFiles = Cells (I,7) to increment through the series of filenames that I want to move. The macro bombs out on the final step.
Any suggestions would be appreciated.
Sub Copying_File()
Sheets("Sheet1").Select
I = 8
Do
I = I + 1
If Cells(I, 7) = "zzzz" Then Cells(I, 8) = "Transfer of Files Complete"
If Cells(I, 7) = "zzzz" Then Exit Do
'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
'This is Your File Name which you want to Copy
sFile = Cells(I, 7).Value & ".pdf"
'Change to match the source folder path
sSFolder = "I:\PatschB\ZZZ Source\"
'Change to match the destination folder path
sDFolder = "I:\PatschB\ZZZ Destination\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Copying File to Destination Folder
FSO.CopyFile (sSFolder & sFile), sDFolder
Loop
End Sub
CopyFile requires two full paths - both should include the file name
Try replacing this line:
FSO.CopyFile (sSFolder & sFile), sDFolder
with this line:
FSO.CopyFile sSFolder & sFile, sDFolder
Related
I currently have a workbook for each person in my team where they have a worksheet named "Panel" that contains their initiatives and progress.
I want to develop a unified spreadsheet containing all their initiatives to have a view of the whole area.
In each "Panel" sheet, the "U5" cell contains the name of the owner. In my consolidated file, I want to put the name of the owner as the name of the corresponding sheet.
I made this macro to get, from a separate folder where they will all put their individual sheets, all the "Panel" sheets, put them in the main file and rename them to identify the owner.
Later on, I'll develop a database with the initiatives, identifying the start and end of the data fields to compile them in a single manner for a dashboard.
This is my code:
Sub GetSheets()
Path = "C:\Users\Admin\Desktop\PMO\Test consolidation\Independent files"
Filename = Dir(Path & "*.xlsm")
Dim wsname As String
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Worksheets("Panel").Activate
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Worksheets("Panel").Select
wsname = Range("U5")
Worksheets("Panel").Name = wsname
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Can you help to identify why this is not working?
Thanks!
Here is an example which checks whether path has \ present, whether sheets exists (code a la Rory) and also whether U5 is empty. Assumes, U5 in workbooks you are opening are being used for renaming.
Option Explicit
Sub GetSheets()
Dim path As String
Dim Filename As String
Dim wbMaster As Workbook
Dim wbActive As Workbook
Dim wsPanel As Worksheet
Set wbMaster = ThisWorkbook
path = "C:\Users\Admin\Desktop\PMO\Test consolidation\Independent files"
If Right$(path, 1) <> "\" Then path = path & "\"
Filename = Dir(path & "*.xlsm")
Dim wsname As String
Do While Filename <> ""
Set wbActive = Workbooks.Open(Filename:=path & Filename, ReadOnly:=True)
With wbActive
If Evaluate("ISREF('" & "Panel" & "'!A1)") Then 'Rory 'https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
Set wsPanel = wbActive.Worksheets("Panel")
wsPanel.Copy After:=wbMaster.Worksheets(1)
If Not IsEmpty(wsPanel.Range("U5")) Then
ActiveSheet.Name = wsPanel.Range("U5")
Else
MsgBox "Missing value to rename worksheet in " & Filename
End If
End If
End With
wbActive.Close
Filename = Dir()
Loop
End Sub
I need a VBA where it updates the "name of the excel file" inside that particular "excel file". There are 12 files in the folder. The path for this folder is D:\Amit. Name of those 12 files are "Cash Report as on 11-05-2017 0000Hrs" starting from Midnight (that's why 0000Hrs) and it increases by 2 hours making it 0200Hrs, 0400Hrs etc. We prepare these files daily after every 2 hours. Sometimes it does happen that we run the file after 3 hours making it 0500Hrs instead of 0400Hrs just after 0200Hrs. What I need is a VBA file which opens all these 12 files and in column A in the last row of each respective file, it mentions the name of that particular file.
Eg. it should open all 12 files and then in the first file named Cash Report as on 11-05-2017, in the last row of column A of this file - it should mention the name of this particular file.
So if the VBA opened file "Cash Report as on 11-05-2017 0400Hrs" then in the last cell of the column A just after the text or data in the cell, using offset the very below blank cell should have the name of this file as "Cash Report as on 11-05-2017 0000Hrs". Likewise, need something like this for all the files which open up each individual file and update the respective file name inside the last row of column A.
I was trying some of the codes but it's still in bits and pieces.
Dim Source As String
Dim StrFile As String
'do not forget the last backslash in the source directory.
Source = "C:\Users\Admin\Desktop\VBA\"
StrFile = Dir(Source)
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir()
Loop
fldr = Activeworkbook.Path
Dt = Application.InputBox("Enter Date as 'dd-mm-yyyy' ", format(Now," dd-mm-yyyy"
Workbooks.open Filename:= fldr & "\Cash Report as on" & 0400 & "Hrs.xlsx"
Range("A1").End(xlDown).Select
Offset(1).Select
Try This
Sub t()
Dim Source As String
Dim StrFile As String
Dim wb As Workbook
'do not forget last backslash in source directory.
Source = "C:\Users\Admin\Desktop\VBA\"
StrFile = Dir(Source)
Do While Len(StrFile) > 0
Set wb = Workbooks.Open(Source & StrFile)
wb.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = wb.Name
StrFile = Dir()
wb.Close (True)
Loop
End Sub
Try something like this.
Assumptions:
The Excel file name will be pasted always in the first Sheet - in case the specific sheets are naming always in the same way change lines Sheets(1) with Sheets("YourName")
Every row in table from column A in Sheets(1) is not empty as I'm using COUNTA function (thx #Darren Bartrup-Cook)
Code:
Sub InsertFileName()
Dim strFolderPath As String
Dim lngLastRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim ErrNumbers As Integer
'Choose folder with Excel files
strFolderPath = GetFolder(ThisWorkbook.Path) & "\"
'Loop through all Excel files in FolderPath
FileName = Dir(strFolderPath & "*.xl*")
Do While FileName <> ""
'Open Excel file
Set WorkBk = Workbooks.Open(strFolderPath & FileName)
'Find the last row in A column
On Error Resume Next
lngLastRow = Application.WorksheetFunction.CountA(WorkBk.Sheets(1).Range("A:A")) + 1
If lngLastRow = 1 Then
ErrNumbers = ErrNumbers + 1
Err.Clear
GoTo NextWkb
End If
WorkBk.Sheets(1).Range("A" & lngLastRow).Value = WorkBk.Name
NextWkb:
'Close file and save changes
WorkBk.Close True
'Next file
FileName = Dir()
Loop
If ErrNumbers <> 0 Then
MsgBox "There were some problems with Excel files. Check if there is some empty sheet or empty A column in one or more Excel files and try again"
Else
MsgBox "Everything went fine!"
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
I am trying to get Excel to open any file in the a given folder
(ThisWorkbook.Path\Peach\Apple) that has .xlsm extension (there is always only 1 file). Is it possible to open it with wildcard character? I do not know the name of the file, just the extension.
If not, is there a way to do it?
Just ask the file system for the first matching file:
Dim path As String: path = ThisWorkbook.path & "\Peach\Apple\"
FindFirstFile = Dir$(path & "*.xlsm")
If (FindFirstFile <> "") Then
Workbooks.Open path & FindFirstFile
Else
'// not found
End If
(This will not search sub-directories)
You mentioned that it would be nice addition to open last modified file or file with shortest name, so let's start - there's a code example how you can grab all three files (first finded, last modified, with shortest name). You can modify this as you wish (add some parameters, add error handling, return only specified, etc).
Sub Test()
'declarations
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim path As String
Dim first_finded As Object
Dim recently_modified As Object
Dim shortest_name As Object
Dim recently As Date
Dim shortest As Long
Dim firstFinded As Boolean
'setting default recently date(24 hours from now) and path
recently = DateAdd("h", -24, Now)
path = ThisWorkbook.path & "\Peach\Apple\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(path)
'iteration over folder
For Each file In folder.Files
If file.Name Like "*.xlsm" Then
'grab first finded .xlsm
If Not firstFinded Then
firstFinded = Not firstFinded
Set first_finded = file
End If
'grab lastmodified .xlsm
If file.DateLastModified > recently Then
recently = file.DateLastModified
Set recently_modified = file
End If
'grab short named .xlsm
If shortest = 0 Or shortest > Len(file.Name) Then
shortest = Len(file.Name)
Set shortest_name = file
End If
End If
Next
'debug-print names
Debug.Print first_finded.Name
Debug.Print recently_modified.Name
Debug.Print shortest_name.Name
'so now you can uncomment this and open what you want
'Call Workbooks.Open(path & recently_modified.Name)
End Sub
Try the code below, it will open your "*.xlsm" file, in the path you've requested.
Sub OpenXLSMWildcardfile()
Dim Path As String
Path = ThisWorkbook.Path & "\Peach\Apple\"
Workbooks.Open (Path & "*.xlsm")
End Sub
PFB for the code required for opening the macro file with extension(.xlsm).
Sub OpeningFile()
'Declaring variables
Dim FileName, FolderPath As String
'Initializing folder path
FolderPath = ThisWorkbook.Path & "\Peach\Apple\"
'Finding the file name using wildcard
FileName = Dir(FolderPath & "*.xlsm")
'Looping through the workbook which are saved as macro enabled workbooks
While FileName <> ""
Workbooks.Open FolderPath & FileName
FileName = Dir()
Wend
End Sub
I'm working on a macro that needs to select any folder I want and import every type of file within that folder that's cvs, xls, txt and put them all into 1 workbook (not sheet). So all the tabs imported would be there. Right now the code can take in only 1 type. I tried changing the code below to:
fileName = Dir(directory & "*.csv, *.xls,*.txt")
but nothing happened.
The macro below has a fixed directory path right now but I would like to have a dialog box pop up which allows me to be flexible in selecting any folder I want to import my files from. Here's what I got so far, but please modify it or make a new one that best works.
Sub Input_Sheets()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "C:\Users\ktam\Desktop\New folder\"
'Switch to the preferred type the folders hold. (It cannot hold 2 types)
'fileName = Dir(directory & "*.xl??")
fileName = Dir(directory & "*.csv")
'As long as the file name is found in the folder, import the file.
Do While fileName <> ""
Workbooks.Open (directory & fileName) 'Opens a random file from the folder
'WrdArray() = Split(fileName, ".")
For Each sheet In Workbooks(fileName).Worksheets
'Workbooks(fileName).ActiveSheet.Name = WrdArray(0) '0 Puts in the name of the document
total = ThisWorkbook.Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy After:=ThisWorkbook.Worksheets(total)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Complete"
End Sub
I have this code that's really useful for looping within a folder and loading the files into an array based on the file names:
Global sfolder As String
sub file_merger()
file = Dir(folderchooser)
dim trackerfiles(1 to 500) as variant
counter = 1
Do While file <> ""
if instr(1,file,".xlsx") > 0 or instr(1,file,".csv") > 0 then
trackerfiles(counter) = sfolder & "\" & file
file = Dir()
counter = counter + 1
If file = "" Then
Exit Do
End If
End if
Loop
end sub
Function folderchooser() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder"
.AllowMultiSelect = False
.Show
sfolder = .SelectedItems(1)
End With
folderchooser = sfolder & "\"
End Function
You could use it load into an array and then write your own code to import the files into your workbook (the tricky part is looping through the folder).
I have 5 folders namely:
version1
version2
version3
version4
version5
each of this folders have four excel files:
gt
ga
ra
fe
ca
I want to fetch a specific column data with column name CC from each of this excel files into different sheets in a workbook. Data is to be fetched from all the folders into single file using VBA. Any assistance please? Thanks!
This code should do what you are looking for.
Note that this code will look in the first row of every workbook to find the value "CC". Also note that this assumes data is on the first sheet of every workbook.
Sub CopyColumns()
Dim TargetWb, SourceWb As Workbook
Dim myPath, myFile, myExtension, LastRowSource, LastRowTarget As String
Dim SourceColNo, TargetColNo, RowNo, SheetNo As Long
Dim Folder, FolderArray As Variant
Dim CopyHeaders As Boolean
Set TargetWb = ActiveWorkbook
Application.ScreenUpdating = False
'******************************************************************************************
' ************************* USER VARIABLES - PLEASE CHANGE ********************************
'******************************************************************************************
'Set Column Index to which data will be entered on this workbook
TargetColNo = 1
'Set the sheet number you wish to start inserting data from
SheetNo = 1
'Copy header row
CopyHeader = True
'Set Target Folder Path which contains folders "Version1" etc
myPath = "C:\New\"
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"
'Folder names to search, should you wish to change, add or remove any
FolderArray = Array("version1", "version2", "version3", "version4", "version5")
'******************************************************************************************
'******************************************************************************************
'******************************************************************************************
'Convert Col No to Letter
Dim TgtColLetter
TgtColLetter = Split(Cells(1, TargetColNo).Address(True, False), "$")
'Loop through folders
For Each Folder In FolderArray
'Target Path with Ending Extention
myFile = Dir(myPath & Folder & "\" & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set SourceWb = Workbooks.Open(Filename:=myPath & Folder & "\" & myFile)
'Find Column named 'CC'
SourceColNo = WorksheetFunction.Match("CC", SourceWb.Sheets(1).Range("A1:H1"), 0)
Dim SrcColLetter
SrcColLetter = Split(Cells(1, SourceColNo).Address(True, False), "$")
'Get Last Row of Source Workbook
LastRowSource = SourceWb.Sheets(1).Cells(Rows.Count, SourceColNo).End(xlUp).Row
'Get Last Row of Target Workbook and add new sheets as required
On Error Resume Next
LastRowTarget = TargetWb.Sheets(SheetNo).Cells(Rows.Count, TargetColNo).End(xlUp).Row
If Err.Number <> 0 Then
TargetWb.Activate
TargetWb.Sheets.Add After:=TargetWb.Worksheets(Worksheets.Count)
End If
On Error GoTo 0
If CopyHeader = False Then
RowNo = 2
Else
RowNo = 1
End If
'Copy from Source to Target
SourceWb.Sheets(1).Range(SrcColLetter(0) & RowNo & ":" & SrcColLetter(0) & LastRowSource).Copy _
Destination:=TargetWb.Sheets(SheetNo).Range(TgtColLetter(0) & LastRowTarget)
'Close Workbook
SourceWb.Close SaveChanges:=False
'Get next file name
myFile = Dir
'Move to next sheet on TargetWb
SheetNo = SheetNo + 1
Loop
Next Folder
Application.ScreenUpdating = True
End Sub