I would like to rename each workbook in a folder as the name of the first worksheet in the workbook. For example, if the Workbook is called "71107" and the worksheet in that workbook is called "foobar", I would like the workbook to be renamed "foobar".
My current progress is as follows:
Sub RunMe()
Dim objFSO As New FileSystemObject
Dim objWkbk As Workbook
Dim objFile As File
Dim folderpath As String
Application.ScreenUpdating = False
folderpath = "D:\test\"
For Each objFile In objFSO.GetFolder(folderpath).Files
oldpath = objFile.path
Set objWkbk = Workbooks.Open(oldpath)
newpath = path & "NEWNAME\" & ActiveSheet.Name & ".xls"
objWkbk.SaveAs Filename:=newpath
objWkbk.Close
Next objFile
End Sub
This code runs extremely slowly (in the order of 10 seconds per file). My files are not large, only around 40kb each. Is there a faster way to perform this operation? I also don't need to save a new copy of each file, I'm quite happy to just rename the file I just don't know of a way to do that.
There are two things, which takes so long one is Open and SaveAs.
The Open can be avoided with ADO as mentioned and more details are here
Then you can also not use SaveAs because it is not opened but you can just rename the file using something like:
Name GivenLocation & OldFileName As GivenLocation & NewFileName
Related
Does there exist a code to for example save every hour the data from A1:B10 in sheet1 to a CSV file ?
Although this can be done in many different ways, this is what I'd do:
1) Add the following sub to a new file. Let's call it "auto.xlsb"
Sub SaveRangeToCSV()
Dim rng As Range
Dim originWB As Workbook
Dim originWS As Worksheet
Dim newBook As Workbook
Dim newBookWS As Worksheet
'Open the file you want to copy the range from
Set originWB = Workbooks.Open("path_to_file_that_contains_the_range_you_want_to_copy.xlsx")
Set originWS = ThisWorkbook.Sheets("name_of_the_sheet_where_the_range_is")
Set rng = originWS.Range("A1:B10")
'Add new workbook (csv file)
Workbooks.Add
Set newBook = ActiveWorkbook
Set newBookWS = newBook.Sheets(1)
'Copy range from origin to destination (csv file)
rng.Copy Destination:=newBookWS.Range("A1")
'Save csv file
newBook.SaveAs Filename:=ThisWorkbook.Path & "\output.csv"
End Sub
If you want to avoid the output.csv to be overwritten every 10 minutes, you could, for example, add current datetime to the filename like this:
'Save csv file
newBook.SaveAs Filename:=ThisWorkbook.Path & "\output_" & Replace(Replace(Replace(Now, "/", ""), ":", ""), " ", "") & ".csv"
2) Add this code to Workbook_Open Sub (click ThisWorkbook sheet in VBA IDE, and select Workbook and Open from the dropdown) in auto.xlsb, and Save:
Private Sub Workbook_Open()
Call Module1.SaveRangeToCSV
End Sub
Every time you doble-click to open the file, SaveRangeToCSV will be triggered and, hence, the csv created.
3) Automating the execution of this file really depends on your preferences and the Operating System you are working on. I'm assuming your are on Windows, so the easiest way to do it would be creating a task in Windows' Task Scheduler which runs "auto.xlsb" every 10 minutes.
I hope this helps.
I am trying to copy a module from one excel workbook to another using VBA.
My Code:
'Copy Macros
Dim comp As Object
Set comp = ThisWorkbook.VBProject.VBComponents("Module2")
Set Target = Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm").VBProject.VBComponents.Add(1)
For some reason, this copies the module, but does not copy the VBA code inside, why?
Please can someone show me where i am going wrong?
Thanks
Sub CopyModule below, receives 3 parameters:
1.Source Workbook (as Workbook).
2.Module Name to Copy (as String).
3.Target Workbook (as Workbook).
CopyModule Code
Public Sub CopyModule(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)
' Description: copies a module from one workbook to another
' example: CopyModule Workbooks(ThisWorkbook), "Module2",
' Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm")
' Notes: If Module to be copied already exists, it is removed first,
' and afterwards copied
Dim strFolder As String
Dim strTempFile As String
Dim FName As String
If Trim(strModuleName) = vbNullString Then
Exit Sub
End If
If TargetWB Is Nothing Then
MsgBox "Error: Target Workbook " & TargetWB.Name & " doesn't exist (or closed)", vbCritical
Exit Sub
End If
strFolder = SourceWB.Path
If Len(strFolder) = 0 Then strFolder = CurDir
' create temp file and copy "Module2" into it
strFolder = strFolder & "\"
strTempFile = strFolder & "~tmpexport.bas"
On Error Resume Next
FName = Environ("Temp") & "\" & strModuleName & ".bas"
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
Err.Clear
Kill FName
If Err.Number <> 0 Then
MsgBox "Error copying module " & strModuleName & " from Workbook " & SourceWB.Name & " to Workbook " & TargetWB.Name, vbInformation
Exit Sub
End If
End If
' remove "Module2" if already exits in destination workbook
With TargetWB.VBProject.VBComponents
.Remove .Item(strModuleName)
End With
' copy "Module2" from temp file to destination workbook
SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
TargetWB.VBProject.VBComponents.Import strTempFile
Kill strTempFile
On Error GoTo 0
End Sub
Main Sub Code (for running this code with the Post's data):
Option Explicit
Public Sub Main()
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ThisWorkbook
Set WB2 = Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm")
Call CopyModule(WB1, "Module2", WB2)
End Sub
Actually, you don't need to save anything to a temporary file at all. You can use the .AddFromString method of the destination module to add the string value of the source. Try the following code:
Sub CopyModule()
Dim SourceVBProject As VBIDE.VBProject, DestinationVBProject As VBIDE.VBProject
Set SourceVBProject = ThisWorkbook.VBProject
Dim NewWb As Workbook
Set NewWb = Workbooks.Add ' Or whatever workbook object you have for the destination
Set DestinationVBProject = NewWb.VBProject
'
Dim SourceModule As VBIDE.CodeModule, DestinationModule As VBIDE.CodeModule
Set SourceModule = SourceVBProject.VBComponents("Module1").CodeModule ' Change "Module1" to the relevsant source module
' Add a new module to the destination project
Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
'
With SourceModule
DestinationModule.AddFromString .Lines(1, .CountOfLines)
End With
End Sub
Should be self-explanatory! The .AddFomString method simply takes a string variable. So in order to get that, we use the .Lines property of the source module. The first argument (1) is the start line, and the second argument is the end line number. In this case, we want all the lines, so we use the .CountOfLines property.
Fantastic Code by Chris Melville, Thanks a ton, just a few small addition which i did & added few comments.
Just make sure, following things are done before running this macro.
VB Editor > Tools > References > (Check) Microsoft Visual Basic for Applications Extensibility 5.3
File -> Options -> Trust Center -> Trust Center Setttings -> Macro Settings -> Trust Access to the VBA Project object model.
Once you do above thing, copy & paste below code in Source File
Sub CopyMacrosToExistingWorkbook()
'Copy this VBA Code in SourceMacroModule, & run this macro in Destination workbook by pressing Alt+F8, the whole module gets copied to destination File.
Dim SourceVBProject As VBIDE.VBProject, DestinationVBProject As VBIDE.VBProject
Set SourceVBProject = ThisWorkbook.VBProject
Dim NewWb As Workbook
Set NewWb = ActiveWorkbook ' Or whatever workbook object you have for the destination
Set DestinationVBProject = NewWb.VBProject
'
Dim SourceModule As VBIDE.CodeModule, DestinationModule As VBIDE.CodeModule
Set SourceModule = SourceVBProject.VBComponents("Module1").CodeModule ' Change "Module1" to the relevsant source module
' Add a new module to the destination project
Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
'
With SourceModule
DestinationModule.AddFromString .Lines(1, .CountOfLines)
End With
End Sub
Now run the "CopyMacrosToExistingWorkbook" macro in destination file, you will see the source file macro copied to destination file.
I had a lot of trouble getting the previous answers to work, so I thought I'd post my solution. This function is used to programmatically copy modules from a source workbook to a newly created workbook that was also created programmatically with a call to worksheet.copy. What doesn't happen when a worksheet is copied to a new workbook is the transfer of the macros that the worksheet depends upon. This procedure iterates through all modules in the source workbook and copies them into the new one. What's more is that it actually worked for me in Excel 2016.
Sub CopyModules(wbSource As Workbook, wbTarget As Workbook)
Dim vbcompSource As VBComponent, vbcompTarget As VBComponent
Dim sText As String, nType As Long
For Each vbcompSource In wbSource.VBProject.VBComponents
nType = vbcompSource.Type
If nType < 100 Then '100=vbext_ct_Document -- the only module type we would not want to copy
Set vbcompTarget = wbTarget.VBProject.VBComponents.Add(nType)
sText = vbcompSource.CodeModule.Lines(1, vbcompSource.CodeModule.CountOfLines)
vbcompTarget.CodeModule.AddFromString (sText)
vbcompTarget.Name = vbcompSource.Name
End If
Next vbcompSource
End Sub
The function should hopefully be as simple as possible and fairly self-explanatory.
You can try
Open both workbooks
Open VBA Dev window
Dropdown Modules and drag and drop a copy from one module are to another
This is to make sure Module Names are not duplicated.
Also if you have modules that contain same named function / Subs then there will be a clash.
I do this and then run debug. Seems to work fine.
P.S. I copy many in to my PERSONAL.xlsb
I have found the below code to save sheet as new workbook but what I wanted to know if it is possible to change the save name
each time the macro is run to the value on sheet 1 in cells B2 and to a specific file location.
I have tried the way below and it just simply saves the file with the name of the file location instead of saving it in the file location specified.
Sub sb_Copy_Save_Worksheet_As_Workbook()
Dim wb As Workbook
Set wb = Workbooks.Add
ThisWorkbook.Sheets("Sheet2").Copy Before:=wb.Sheets(1)
wb.SaveAs "C:\temp\test1.xlsx"
End Sub
Any help would be greatly appreciated
many thanks
Jamie
Let's say "Sheet1" has in cell B2 the value "test1" (the filename), then you can use the following:
Sub sb_Copy_Save_Worksheet_As_Workbook()
Dim wb As Workbook
Dim myPath As String
Dim myFilename As String
Dim myFileExtension As String
myPath = "C:\temp\" 'you can change this
myFileExtension = ".xlsx"
myFilename = ThisWorkbook.Sheets("Sheet1").Range("B2").Value
Set wb = Workbooks.Add
ThisWorkbook.Sheets("Sheet2").Copy Before:=wb.Sheets(1)
wb.SaveAs myPath & myFilename & myFileExtension
wb.Close False
End Sub
If your cell B2 already includes the file extension (so it is "test1.xlsx" in B2), just remove the myFileExtension parts from the code.
The folder, where you want to save your file has to exist. If you need help checking this or creating the folder in your macro, please leave a comment.
Try adding on the cell value to the path string like this:
Sub sb_Copy_Save_Worksheet_As_Workbook()
Dim wb As Workbook
Set wb = Workbooks.Add
ThisWorkbook.Sheets("Sheet2").Copy Before:=wb.Sheets(1)
wb.SaveAs "C:\temp\" & ThisWorkbook.Sheets("Sheet2").Range("B2").Value
End Sub
File extension will default to .xlsx even if the original file is .xlsm so you don't need to add this to the path string.
I am attempting to scan through a specific folder and open the most recently titled Excel file. The files are named '10 1 13' and '10 2 13' ect. My sub correctly identifies the most recent file. However, when it attempts to open it, I get the following error:
'Filename' is currently in use. Try again later.
The file will usually be in use by someone, but is only modified once a day. All I need to do is open a read-only workbook and copy data from it. No modifying or saving is required, which is why I tried the 'ReadOnly:= True' arguement, but I still get an error message.
The file path '\Hsrkdfs\hsdata\rk\grp06....' is because I am pulling from a network where everyone's network access isn't mapped the same. Some access this folder from the G: drive, others the R:, and this macro must be functional from all computers. Debug points me to the 'Workbooks.Open Filename:=strFilename, ReadOnly:=True' line.
Is there a more robust way to open the Workbook? Another method to force it open regardless of use? Or a way to avoid the conflict entirely? Thank you.
Sub GetMostRecentFile()
Dim FileSys As FileSystemObject
Dim objFile As File
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
'set path for files - CHANGE FOR YOUR APPROPRIATE FOLDER
Const myDir As String = "\\Hsrkdfs\hsdata\rk\grp06\Rockford Repair Station Quality\DELIVERY\Daily Status report - commercial"
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Path
End If
Next objFile
Workbooks.Open Filename:=strFilename, ReadOnly:=True
Set FileSys = Nothing
Set myFolder = Nothing
End Sub
Try using GetObject if you only need to read the file. Something like this:
Dim wb As Workbook
Set wb = GetObject(strFilename)
'Change this line to reflect the ranges you need to copy/paste.
wb.Sheets("Sheet1").Range("A1").Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
wb.Close
Using this should allow you to copy from the workbook whether it's open by another user or not (including you).
I have noticed that this approach doesn't work if the workbook is protected or if the sheet you're trying to copy from is protected.
Also, only use ThisWorkbook like I did above if the code will be in the same workbook as the sheet you want to paste to.
I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.