I have a lot of files in one folder. What I want to do is add a column with the name of the file. I found a solution to this, but I want to optimize. Currently I am just adding the values from J2 to J1000 to make sure I cover all rows. This is not ideal as the amount of rows in each file differ. What I want to do is find a way to add the value matching the amount of rows that exists in the sheet.
I want to find a way to check if there is data in column A for each row and then add the value as long as there is some data in column A for each row.
My thoughts would be to do a while statement to check if each row in column A is different from an empty string and add the value as long as it is different from an empty string. However I am not sure how to implement this.
Here is my code:
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(FileName:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
Sheets(1).Range("j1").Value = "Date"
Sheets(1).Range("j2:j1000").Value = Mid(ActiveWorkbook.Name, 10, 10)
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
Related
I'm trying to create a VBA code to do this:
Open a dialog box to choose a word file in the path: C:\Add-in\Company A\Templates in docx format
Select as active sheet Navette the file: "Checklist - Navette" if there's no open file with this name appear a message: "ERROR Please push the comand checklist first" and quit the macro
Populate all the bookmarks of the word file with content cells that have name equal as the bookmarks (use sheet Navette)
If the Navette sheet has a cell named "Civilité" and the content is equal to "Female" must go to the excel file in the path: C:\Add-in\Mapping.xlsx on the Replace sheet and search all the words in the column A throught the word file and replace with words in the column B otherwise replace with the words in the column C
Open a dialog box to input the path to save the word with the name TEST in word and pdf format
Close the initial files without saving
Quit all aplications
I'm stucked in the code and it's even working. When I try to run It also get stucked :(
Sub TestProcess()
'Initial process
Dim fd As FileDialog
Dim strFile As String
Dim wdDoc As Document
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim SaveAsFileName As String
Dim SaveAsFileFormat As Integer
'Dialog box to pickup the docx file
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = "C:\Add-in\Company\Templates"
.Filters.Add "Word Files", "*.docx", 1
If .Show = -1 Then
strFile = .SelectedItems(1)
End If
End With
Set wdDoc = Documents.Open(strFile)
'Identify the checklist
On Error Resume Next
Set wb = Workbooks("Company - Navette.xlsx")
On Error GoTo 0
'Handling with errors
If wb Is Nothing Then
MsgBox "ERROR 'Please select the command *Open Navette*first"
wdDoc.Close
Set wdDoc = Nothing
Exit Sub
End If
'Active Worksheet
On Error Resume Next
Set ws = wb.Sheets("Navette")
On Error GoTo 0
'Handling with errors
If ws Is Nothing Then
MsgBox "Sheet 'Navette' not found in the workbook."
'For each Bookmark equal name cell replace with the content
For Each wdBookmark In wdDoc.Bookmarks
wdBookmark.Range.Text = ws.Range(wdBookmark.Name).Value
Next
'Save file
'Open a dialog box to input the path to save the Word file
SaveAsFileName = Application.GetSaveAsFilename(FileFilter:="Word Files (*.docx), .docx; PDF Files (.pdf), *.pdf", Title:="Save As", InitialFileName:=strFile)
'Check if a file name and format are selected
If SaveAsFileName <> "False" Then
'Determine the selected file format
If Right(SaveAsFileName, 4) = ".pdf" Then
SaveAsFileFormat = 17
Else
SaveAsFileFormat = 0
End If
'Save the file in the selected format
objDoc.SaveAs SaveAsFileName, FileFormat:=SaveAsFileFormat
End If
'Close Doc & Excel
wdDoc.Close
wb.Close
'Reset the documents
Set wdDoc = Nothing
Set wb = Nothing
Exit Sub
End If
End Sub
I got WB with different number of sheets and with the same structure and so on. There is one field let's say D8 as an example where is written number 3 (CH) and based on that number in that cell, I would like to export exactly that number of sheets into one PDF. So, if it is written five, then five pages into one PDF...or if it is one then one page in PDF.
That cell in D8 will be always on the same position, but the number might differ. Can this be somehow written into the code to look on this number and to export that many sheets into one PDF?
And I would like to have an option where to save every new PDF, not like now that is automatically created, firstly folder and then file.
Here is SS of my WB:
and this is piece of code what I was using but just to save sheets into single PDF, I am not so good in VBA so any help will be great!
Sub ExportAsPDF()
Dim FolderPath As String
FolderPath = "C:\Users\XYZ\Desktop\PDFs"
MkDir FolderPath
Sheets(Array("CH1", "CH2", "CH3")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath & "\PDf", _
openafterpublish:=False, ignoreprintareas:=False
MsgBox "All PDF's have been exported!"
End Sub
When you ask a question, it is recommended to frequently check it and try clarifying the comments asking for clarifications...
If I understood well your question, please test the next code. It assumes that the answer to my suppositions in the comment is yes. The code offers a browse window to select the folder where to export the chosen (sheetsNo) number of sheets:
Sub ExportAsPDF()
Dim FolderPath As String, sheetsNo As Long, sh As Worksheet, arrSheets
Dim fldr As FileDialog, sItem As String, fileName As String, i As Long
sheetsNo = ActiveCell.value 'use there the sheet you need
ReDim arrSheets(sheetsNo - 1) 'redim the array to keep the sheets
'use a dialog to select the folder to export
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder where to export the pdf file"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
If sItem = "" Then Exit Sub 'if no folder selected the code stops
FolderPath = sItem
fileName = Replace(ThisWorkbook.Name, ".xlsm", ".pdf") 'use the workbook name, but changing its extension
For i = 1 To sheetsNo
arrSheets(i - 1) = Worksheets(i).Name 'put the sheets in an array
Next
Sheets(arrSheets).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=FolderPath & "/" & fileName, _
openafterpublish:=False, ignoreprintareas:=False
MsgBox "All PDF's have been exported!"
End Sub
Please, test it and send some feedback.
I have three files. One excel file that is empty and contains my Macro. Second excel file that has about 20 tabs with updated data (Variable "UpdatedFiles" contains the file path) that needs to by copy/pasted into my third excel file (Variable "ProvisionFiles" contains the file path), that has extra tabs that link to the tabs that I am copy/pasting in.
My code works great right up to the point that I hit the Copy/Paste Section of my For Each Loop. Note that the tabs that I am copying over have the overlapping/same tab names in both workbooks.
I have tried to copy/paste data with all three methods described in this video. https://www.excelcampus.com/vba/copy-paste-cells-vba-macros/
Still can't get it to work.
`Sub CopyPasteData()
Dim ProvisionFile As String 'String File Path of Provision File
Dim UpdatedFile As String 'String File Path of Updated OneSource Files
Dim ws As Worksheet 'Used to Loop Though WS Tabs in Updated OneSource Files
Dim wsName As String 'Name of Tab of OneSource File
Dim lastRow As Long
Dim lastColumn As Long
'Open Dialog Box that allows you to Select the Provision File
MsgBox "Select your provision file, which is the destination for the updated OneSource Reports. Please ensure this file is closed before opening."
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Select file"
.InitialFileName = "C:\"
If .Show = -1 Then
'ok clicked
ProvisionFile = .SelectedItems(1)
Workbooks.Open(ProvisionFile).Activate
'Worksheets("Control").Activate
Else
'cancel clicked
End If
End With
'Get updated Reports
MsgBox "Select the file that contains the updated OneSource Reports."
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Select file"
.InitialFileName = "C:\"
If .Show = -1 Then
'ok clicked
UpdatedFile = .SelectedItems(1)
Workbooks.Open(UpdatedFile).Activate
Else
'cancel clicked
End If
End With
'Loop through Each tab in Updated File
For Each ws In Worksheets
wsName = ws.Name
lastRow = Sheets(wsName).Cells(Rows.Count, 1).End(xlUp).Row
lastColumn = Sheets(wsName).Cells(7, Columns.Count).End(xlToLeft).Column
'Debug.Print ("Yes")
Workbooks(ProvisionFile).Worksheets(wsName).Range(Workbooks(ProvisionFile).Worksheets(wsName).Cells(1, 1), Workbooks(ProvisionFile).Worksheets(wsName).Cells(lastRow, lastColumn)) = Sheets(wsName).Range(Sheets(wsName).Cells(1, 1), Sheets(wsName).Cells(lastRow, lastColumn))
Next ws
End Sub`
Expected result is to finish the copy/paste loop.
Error I am recieving = Run-time error'9': Subscript out of range
I would like to know if this is possible so please don't see this as a "create my project for me" post
We are sending usage reports to our customers once a quarter (every 90 days from the date they bought the license). This report contains major tables with 30+ columns of raw number data.
I want to create a simple >drag new report into folder >paste results of main workbook into report
Creating a this is obviously simple but I want to:
Download the usage report (the filename represents the client
name)
Store all these reports in a single folder
Have the core workbook detect new file
Core workbook reads the new excel file, adds the data to a new sheet on the core workbook
Delete the workbook (the new usage report dragged into the folder) after the data has been added
Core workbook creates appropriate content (graphs etc) from the
new data
Are 3, 4, and 5 possible with VBA? I am not familiar with it at all and only recently discovered the possibility of macros in excel.
Below I have a macro which opens all workbooks in a folder one by one, you'll notice where I have commented out a section, here you can enter your code and perform an action on the given workbook. This will loop through each workbook in your folder until there isn't any left.
Sub ImportMacro()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them'
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Values in sheets'
Dim VolatilityPortfolio As String
Dim ColValue As String
VolatilityPortfolio = "VolatilityPortfolio"
'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 = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel'
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")'
myExtension = "*.xl??"
'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)
'-------------------- Below is the worksheet macro --------------------------'
'To open the currentworkbook
Workbooks(myFile).activate
'---------------------------- Above is the worksheet macro ----------------------- '
'Save and Close Workbook as CSV'
wb.Close SaveChanges:=True
'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
I'm looking to open multiple Excel files and run the same macro (contained in each) on each file.
For example, I'd like to automatically open every file in h:\dbs and execute the CmdUpdate_Click macro within each file.
How might I go about this?
Try something like this. I expect you can research how to open the Visual Basic Editor and figure out where to paste this.
'Declare variables
Dim FolderObj, FSO, FileObj As Object
Dim FolderDialog As FileDialog
'Create and run dialog box object
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = "B:\BIM Projects\"
.InitialView = msoFileDialogViewDetails
'Check if user canceled dialog box
'Exit if yes
If .Show = -1 Then
MsgBox "No Folder Selected"
Exit Sub
End If
End With
'Check if user canceled dialog box
'Exit if yes
'Create a File System Object to be the folder that was selected
Set FSO = CreateObject("scripting.filesystemobject")
Set FolderObj = FSO.getfolder(FolderLocation)
'For each obj in the selected folder
For Each FileObj In FolderObj.Files
'Test if the file extension contains "xl" and make sure it's an Excel file before opening
If InStr(1, Right(FileObj.Name, Len(FileObj.Name) - InStr(1, FileObj.Name, ".")), "xl") = 1 Then
'Prevent the workbook from displaying
ActiveWindow.Visible = False
'Open the Workbook
Workbooks.Open (FolderObj & "\" & FileObj.Name)
'Run the Macro
Application.Run "'" & FolderObj & "\" & FileObj.Name & "'!CmdUpdate_Click"
'Save the Workbook
Workbooks(FileObj.Name).Save
'Close the Workbook
Workbooks(FileObj.Name.Close
End If
'Turn this back on
ActiveWindow.Visible = True
Next
I will caution you that this is based on some code I wrote for Word, so there are no guarantees it will work and I don't have time to test it. It will, however, give you a very good start if it doesn't.
Edit to Add: You may