I have daily excel reports that get created by an external program. I am looking to automate a simple row formatting on these reports. They always have the same number of columns, however, different number of rows.
This is the macro I have in place: (it does the job as expected when run on a single xlsm file, which is not ideal)
Sub FormatLeadLists()
Application.DisplayAlerts = False
Columns("A:F").Select
Selection.ColumnWidth = 8.29
Columns("A:F").EntireColumn.AutoFit
Range("A1").Select
Selection.CurrentRegion.Select
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "Table1"
Range("Table1[#All]").Select
End Sub
This is the .vbs code that I run from a batch file:
Dim args, objExcel
Set args = WScript.Arguments
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open args(0)
objExcel.Visible = True
objExcel.Run "FormatLeadLists"
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close(0)
objExcel.Quit
This works well on a single file, however, to make this work I have to create my macro in my "All Open workbooks" and have to save my excel as an xlsm file.
That's not ideal if I have these reports overwritten every day as xlsx files.
How can I create a macro in my personal workbook so I don't have to save the report as xlsm and so I can apply the same macro on the other xlsx reports?
I know I should even be able to create a .vbs file that loops through my windows folder and applies the macro on all existing excel files.
Edit:
Code for the loop (from comments):
Dim strFileName As String
Dim strFolder As String: strFolder = "C:\myfiles\"
Dim strFileSpec As String: strFileSpec = strFolder & "*.*"
strFileName = Dir(strFileSpec)
Do While Len(strFileName) > 0
Debug.FormatLeadLists strFileName
strFileName = Dir
Loop
Related
I want the macro to backup my xlsm file as xlsx format, still remain there after save as xlsx type. However, below coding will convert the existing xlsm file to xlsx file, causing my macro file dissapear. Any suggestion to avoid this, I want xlsx file save and close while xlsm file remain?
Sub backup()
Application.DisplayAlerts = False
ThisWorkbook.saveas "C:\Users\Documents\Book1.xlsx", xlOpenXMLWorkbook
Application.DisplayAlerts = True
End Sub
Use SaveCopyAs.
Sub Test()
Dim wb As Workbook, wb2 As Workbook
Dim Path As String
Application.DisplayAlerts = False
Path = "C:\Users\" & Environ("Username") & "\Desktop\"
Set wb = ThisWorkbook
wb.SaveCopyAs (Path & "File.xlsm")
Set wb2 = Workbooks.Open(Path & "File.xlsm")
wb2.SaveAs Path & "File1.xlsx", xlOpenXMLWorkbook
wb2.Close
Application.DisplayAlerts = True
End Sub
This would save a copy to your desktop, but does not affect the Workbook you are working in.
ThisWorkbook addresses the workbook in which the code is located. If you wish to save the ActiveWorkbook you must address it either as ActiveWorkbook or by its name.
Once you save ThisWorkbook in xlsx format the code can't continue to run. To do what you intend to do you might place the code in a third file, like an add-in, and manipulate your workbooks from there.
I have a requirement from the client in which they want us to rename the column from multiple excel sheets which are present in the same directory.
There are 70+ excel reports and we are not sure that the particular column is present in which excel file. So every time they ask us to change, all the time we have to drill down all the excel sheets to find out the changes required which is really time consuming.
I thought of automating the process. Since all the files are present under the same directory, can't we use a MACRO,BATCH/UNIX SCRIPTS or any other way by which we can traverse the entire directory and make those changes by performing a find and replace thing.
So my first question is, if this is feasible ? If yes, then can anyone suggest/advice how to work around on this process ?
Thanks in Advance
I can't take full credit for the below as this is a patchwork of code I have used over the years. This is how I would go about it personally:
Manually make a copy of the files to change and place them in a folder (keep the originals safe!)
Let the code open each file and change it
Code will save a copy in a different 'done' folder
The example below loops through each Excel file and moves it from the 'to-do' folder to the 'done' folder once it has changed the cell "A1" to "Hello World". When the 'to-do' folder is empty the code stops.
You'll need to change the file paths for this to work.
Sub Example()
Dim FolderPath As String, FilePath As String, FileCount As Integer
Dim objExcelApp As Object
Dim wb As Object
Dim SaveName As String
FolderPath = "C:\Users\********\Desktop\To Do\"
NewFolderPath = "C:\Users\********\Desktop\Done\"
FilePath = FolderPath & "*.xl??"
FileName = Dir(FilePath)
ChangeNextFile:
FileCount = 0
'count how many files in "files to be changed" folder
Do While FileName <> ""
FileCount = FileCount + 1
FileName = Dir()
Loop
'if there are no files left end the code
If FileCount = 0 Then GoTo FinishedLoadingFiles
'choose the first file to change
FileName = Dir(FilePath)
Debug.Print FileName
'create an instance of Excel
Set objExcelApp = CreateObject("Excel.Application")
With objExcelApp
.Visible = False
.DisplayAlerts = False
End With
'opens the excel file in the background
objExcelApp.Workbooks.Open FileName:=FolderPath & FileName, UpdateLinks:=False
Set wb = objExcelApp.ActiveWorkbook
objExcelApp.ActiveWindow.Activate
'changes cell "A1" to say "hellow world"
wb.Sheets(1).Cells(1, 1).Value = "Hello World"
'saves the file in the done pile
wb.saveas NewFolderPath & FileName '& ".xlsb"
'closes excel
With objExcelApp
.DisplayAlerts = True
End With
wb.Close
objExcelApp.Quit
Set wb = Nothing
Set objExcelApp = Nothing
'deletes the original file. New file has been saved in the new folder
Kill FolderPath & FileName
GoTo ChangeNextFile
FinishedLoadingFiles:
MsgBox "All done"
End Sub
I have multiple files with data that need to be transposed into a single master file with all the data into a single row.
I'm a complete noob in programming so if the code I have so far doesn't make any sense, then please feel free to change it
I was able to find this "Loop all excel files in a folder" code from www.TheSpreadsheetGuru.com The code works perfectly fine, it will open up each file individually in the folder and then close it, and then open the next file and close it until it has gone through every file in that folder.
However, I'd like to insert a "copy and paste data" code loop within the loop. So what needs to happen is, the code will open "File1" in the folder, and then copy and paste the data into the "Master File" in cell A4. Then it will close "File1", and then open up "File2" and copy the data into "Master File" in cell A5 and then close "File2". It will repeat this until all files in the folder have been opened/closed.
This is the code I have right now, but I can't get the copy and paste code to work properly. I'm having a hard time figuring out how to set the loop up where the code will know what file it is currently on and setting a counter for the cell of the Master File that it is pasting into.
Sub LLoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "March"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancelhow
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'THIS IS MY COPY AND PASTE CODE (DOESN'T WORK)
Dim row As Integer
While row = 4
Workbooks("Filename:=myPath & myFile").Worksheets("Resin Log").cell("I5") = Workbooks("Workbook1.xlsm").Worksheets("Sheet1").Range("A" & row).Value
Next row
'Save and Close Workbook
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
It is possible to do what you're talking about. I would suggest, trying to just set cell values in the file being created directly
targetworkbook.worksheets(1).Range("A1").value = sourceworkbook.Worksheets(1).Range("C4").value
rather than using .Copy & .Paste so that if the macro takes a while to run you aren't locked out of using Copy/Paste in other applications. If you're still unsure of what to do, try doing it with Record Macro turned on. The generated code will need tweaked, but will give you most of what you need.
Also, be sure to look at this link for some other things to avoid using in your code.
I appreciate there are lots of entries like save individual excel sheets as csv
and Export each sheet to a separate csv file - But I want to save a single worksheet in a workbook.
My code in my xlsm file has a params and data sheet. I create a worksheet copy of the data with pasted values and then want to save it as csv. Currently my whole workbook changes name and becomes a csv.
How do I "save as csv" a single sheet in an Excel workbook?
Is there a Worksheet.SaveAs or do I have to move my data sheet to another workbook and save it that way?
CODE SAMPLE
' [Sample so some DIMs and parameters passed in left out]
Dim s1 as Worksheet
Dim s2 as Worksheet
Set s1 = ThisWorkbook.Sheets(strSourceSheet)
' copy across
s1.Range(s1.Cells(1, 1), s1.Cells(lastrow, lastcol)).Copy
' Create new empty worksheet for holding values
Set s2 = Worksheets.Add
s2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
' save sheet
s2.Activate
strFullname = strPath & strFilename
' >>> BIT THAT NEEDS FIXIN'
s2.SaveAs Filename:=strFullname, _
FileFormat:=xlCSV, CreateBackup:=True
' Can I do Worksheets.SaveAs?
Using Windows 10 and Office 365
This code works fine for me.
Sub test()
Application.DisplayAlerts = False
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
It's making a copy of the entire strSourceSheet sheet, which opens a new workbook, which we can then save as a .csv file, then it closes the newly saved .csv file, not messing up file name on your original file.
This is fairly generic
Sub WriteCSVs()
Dim mySheet As Worksheet
Dim myPath As String
'Application.DisplayAlerts = False
For Each mySheet In ActiveWorkbook.Worksheets
myPath = "\\myserver\myfolder\"
ActiveWorkbook.Sheets(mySheet.Index).Copy
ActiveWorkbook.SaveAs Filename:=myPath & mySheet.Name, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Next mySheet
'Application.DisplayAlerts = True
End Sub
You just need to save the workbook as a CSV file.
Excel will pop up a dialog warning that you are saving to a single sheet, but you can suppress the warning with Application.DisplayAlerts = False.
Don't forget to put it back to true though.
Coming to this question several years later, I have found a method that works much better for myself. This is because the worksheet(s) I'm trying to save are large and full of calculations, and they take an inconvenient amount of time to copy to a new sheet.
In order to speed up the process, it saves the current worksheet and then simply reopens it, closing the unwanted .csv window:
Sub SaveThisSheetInParticular()
Dim path As String
path = ThisWorkbook.FullName
Application.DisplayAlerts = False
Worksheets("<Sheet Name>").SaveAs Filename:=ThisWorkbook.path & "\<File Name>", FileFormat:=xlCSV
Application.Workbooks.Open (path)
Application.DisplayAlerts = True
Workbooks("<File Name>.csv").Close
End Sub
Here the Sheet and csv filename are hardcoded, since nobody but the macro creator (me) should be messing with them. However, it could just as easily be changed to store and use the Active Sheet name in order to export the current sheet whenever the macro is called.
Note that you can do this with multiple sheets, you simply have to use the last filename in the close statement:
Worksheets("<Sheet 1>").SaveAs Filename:=ThisWorkbook.path & "\<File 1>", FileFormat:=xlCSV
Worksheets("<Sheet 2>").SaveAs Filename:=ThisWorkbook.path & "\<File 2>", FileFormat:=xlCSV
[...]
Workbooks("<File 2>.csv").Close
So the issue I'm having is we have a schedule program made via excel, that is set to replace all user names and shift times with "####" and where it would normally display names inputs "Contact blah blah for new version." This occured on 1/1/15. For now they can backdate their computer to a date prior to 1/1/15 and once they type a value in to any cell the worksheet runs and all their data re-appears. We have locations across the country that saves the file every two weeks to Wildcardname.xls I'm looking for a way to program a command button that finds the other random name opened workbook, goes to hidden sheet "help" and changes the value of Cell A184 to "01/01/2016" or any date I plug in. Which would remove the "####" issue and replace it with the originally inputed values. The user could then save the file and carry on.
I was browsing through various help boards and found this..prompts a user to select the workbook. This would be the workbook that needs changed.
http://www.excelforum.com/excel-programming-vba-macros/695467-copy-values-from-a-worksheet-to-another-workbook-source-workbook-name-unknown.html
Sub CopyData()
Dim DstRng As Range
Dim DstWkb As Workbook
Dim DstWks As Worksheet
Dim FileFilter As String
Dim Filename As String
Dim SrcRng As Range
Dim SrcWkb As Workbook
Dim SrcWks As Worksheet
Dim SheetName As String
SheetName = "Output Table"
FileFilter = "Excel Workbooks (*.xls), *.xls"
Filename = Application.GetOpenFilename(FileFilter, , "Open Source Workbook")
If Filename = "False" Then
MsgBox "Open Source File Canceled."
Exit Sub
End If
Set SrcWkb = Workbooks.Open(Filename)
Set SrcWks = SrcWkb.Worksheets(SheetName)
Set SrcRng = SrcWks.Range("A2:H20")
FileFilter = "Excel Workbooks (*.xls), *.xls"
Filename = Application.GetOpenFilename(FileFilter, , "Open Destination Workbook")
If Filename = "False" Then
MsgBox "Open Destination File Canceled."
Exit Sub
End If
Set DstWkb = Workbooks.Open(Filename)
Set DstWks = DstWkb.Worksheets(SheetName)
Set DstRng = DstWks.Range("A2:H20")
SrcRng.Copy Destination:=DstRng
End Sub
Can this be modified to accomplish what I want to complete?
I can't post an image yet, so here's a link to a mock up. Before shot of the program on the left, and on the right is what I want it to look like.
http://i528.photobucket.com/albums/dd330/DLN1223/mockup.jpg
Hopefully this description makes since....
Thanks in advance for your help.
This is what I use:
Dim FileToOpen As Variant
Dim WKbook as workbook
FileToOpen = Application.GetOpenFilename("Excel files (*.xlsx),*.xlsx", , "Select Workbook to Open")
If FileToOpen = False Then Exit Sub 'quit on cancel
Set Wkbook = Workbooks.Open(FileToOpen, False, False)
With this, I can the set the value I want, and save changes
Wkbook.Sheets("help").Range("A184")=#1/1/2016#
Wkbook.Close SaveChanges:=True
depending on the filetype, you may need to change Excel files (*.xlsx),*.xlsx to Excel files (*.xls),*.xls