I am looking for a code to search a directory for specific file names with a changing number at the end of the name (File_1.xls, File_2.xls, File_3.xls, etc.) and stack the data within the reports on top of eachother without headers into a tab but if a File_Amend.xls file exists then it will only copy the data from that file and paste it into it's own tab. The only changing part of the File_ is 1,2,3, etc. or Amend. Everything ends in .xls
I've gotten this far:
Sub SaveFile()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim File As String
Dim wsCopy As Worksheet
Dim wsCopy2 As Worksheet
Dim wsCopy3 As Worksheet
Dim wsPaste As Worksheet
' For this part I am looking to have the file name constant as "File_" and then have the code search for files with the numbers 1,2,3,4, etc. instead of hardcoding in the file name
File = "L:\Main\Code\"
Set wsCopy = File & wb.Sheets("Main").Range("C6") 'this value is "File 1.xls"
Workbooks.Open Filename:=wsCopy, ReadOnly:=True
Set wsCopy2 = File & wb.Sheets("Main").Range("C7") 'this value is "File 2.xls"
Workbooks.Open Filename:=wsCopy2, ReadOnly:=True
Set wsCopy3 = File & wb.Sheets("Main").Range ("C8") 'this value is "File Amend.xls"
Workbooks.Open Filename:=wsCopy3, ReadOnly:=True
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)
If Dir(wsCopy) = True Then
wsCopy.Range ("A:I").Copy
wsPaste.Cells.PasteSpecial Paste:=xlPasteValues
If Dir(wsCopy2) = True Then
wsCopy2.UsedRange.Offset(1,0).SpecialCells(xlCellTypeVisible).Copy
wsPaste.Cells (Rows.Count, "A").End(x1Up).Offset (1, 0).PasteSpecial Paste: xlPasteValues
If Dir(wsCopy3) = True Then
wsPaste.Cells.ClearContents
wsCopy3.Range("A:I").Copy
wsPaste.Range("Al").PasteSpecial Paste:=xlPasteValues
End Sub
For searching filenames with different numbers, you can use different constant "File", and FOR loop.
Special check for File_Amend.xls can be put before the above code, all like this:
If Dir ("L:\Main\Code\File_Amend.xls" = True then
...
Else
File = "L:\Main\Code\File_"
For i = 1 to 99
wsCopy = File & i & ".xls"
...
Next i
End if
Related
I am trying to break out a data file by 5,000 rows due to limitation with a tool. I have a template file that has multiple sheets (I only have to update data on the first sheet titled 'Service Template', but I need all tabs present on the newly created files). The tool requires the template file to be used so I have to use that file instead of copying the data to a completely new file. I am also attempting to do this on a Mac, but can use virtual machine if absolutely necessary.
The data file and the template file both start on row 2 as both files have headers.
I have the below code that I have been trying to build out but it is still not working and I am stuck.
Data file sheet = 'Sheet1' and Template File Sheet = 'Service Template'
Sub test()
Dim lastRow As Long, myRow As Long, myBook As Workbook
ActiveSheet.Name = "Sheet1"
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For myRow = 1 To lastRow Step 5000
Set myBook = Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
ThisWorkbook.Sheets("Sheet1").Rows(myRow & ":" & myRow + 4999).EntireRow.Copy myBook.Sheets("Sheet1").Range("A2")
Application.DisplayAlerts = False
myBook.SaveAs Filename:="\Users\Downloads\Test\" & myBook.Name
Application.DisplayAlerts = False
myBook.Close
Next myRow
End Sub
I am looking to transfer 5000 rows (starting row2) from the data file to the template file (starting row2) save as a new file and then keep doing the same process until all of the rows are complete.
Try something like this:
Sub test()
Const BLOCK_SIZE As Long = 5000
Dim wsSrc As Worksheet, myBook As Workbook, rngCopy As Range
Set wsSrc = ActiveSheet 'or some other specific sheet
Set rngCopy = wsSrc.Rows(2).Resize(BLOCK_SIZE)
Do While Application.CountA(rngCopy) > 0 'loop while range has content
With Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
rngCopy.Copy .Worksheets("Sheet1").Range("A2")
.SaveAs "\Users\Downloads\Test\" & "R" & rngCopy.Row & "_" & .Name
.Close SaveChanges:=True
End With
Set rngCopy = rngCopy.Offset(BLOCK_SIZE) 'next block down
Loop
End Sub
This question already has answers here:
Run Excel Macro from Outside Excel Using VBScript From Command Line
(8 answers)
Closed 3 months ago.
This post was edited and submitted for review 3 months ago and failed to reopen the post:
Original close reason(s) were not resolved
I am trying to call a VBA function from VBS script:
VBA
Function f_split_master_file(output_folder_path As String, master_excel_file_path As String) As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo ErrorHandler
Dim wb As Workbook
Dim output As String
' Variables related with the master excel file
Dim wb_master As Workbook
Dim ws_master As Worksheet
Dim master_range As Range
Dim responsible_names_range As Range
Dim responsible_name As Range
Dim last_row_master As Integer
' Variables related with the responsible name excel
Dim savepath As String
Dim wb_name As Workbook
Dim ws_name As Worksheet
Dim name As Variant
' Check whether master file exists
If Len(Dir(master_excel_file_path)) = 0 Then ' Master file does not exist
Err.Raise vbObjectError + 513, "Sheet1::f_split_master_file()", "Incorrect Master file path, file does not exist!"
End If
' Check whether output folder exists
If Dir(output_folder_path, vbDirectory) = "" Then ' Output folder path does not exist
Err.Raise vbObjectError + 513, "Sheet1::f_split_master_file()", "Incorrect output folder path, directory does not exist!"
End If
Set wb_master = Workbooks.Open(master_excel_file_path)
Set ws_master = wb_master.Sheets(1)
last_row_master = ws_master.Cells(Rows.Count, "AC").End(xlUp).row
Set master_range = ws_master.Range("A1:AD" & last_row_master)
Set responsible_names_range = ws_master.Range("AC2:AC" & last_row_master) ' Get all names
data = get_unique_responsibles(responsible_names_range) 'Call function to get an array containing distict names (column AC)
For Each name In data
'Create wb with name
savepath = output_folder_path & "\" & name & ".xlsx"
Workbooks.Add
ActiveWorkbook.SaveAs savepath
Set wb_name = ActiveWorkbook
Set ws_name = wb_name.Sheets(1)
master_range.AutoFilter 29, Criteria1:=name, Operator:=xlFilterValues
master_range.SpecialCells(xlCellTypeVisible).Copy
ws_name.Range("A1").PasteSpecial Paste:=xlPasteAll
wb_name.Close SaveChanges:=True
' Remove filters and save workbook
Application.CutCopyMode = False
ws_master.AutoFilterMode = False
Next name
CleanUp:
' Close all wb and enable screen updates and alerts
For Each wb In Workbooks
If wb.name <> ThisWorkbook.name Then
wb.Close
End If
Next wb
Application.ScreenUpdating = True
Application.DisplayAlerts = True
f_split_master_file = output ' empty string if successful execution
Exit Function
ErrorHandler:
' TODO: Log to file
' Err object is reset when it exits from here IMPORTANT!
output = Err.Description
Resume CleanUp
End Function
VBS
Set excelOBJ = CreateObject("Excel.Application")
Set workbookOBJ = excelOBJ.Workbooks.Open("C:\Users\aagir\Desktop\BUDGET_AND_FORECAST\Macro_DoNotDeleteMe_ANDONI.xlsm")
returnValue = excelOBJ.Run("sheet1.f_split_master_file","C:\Users\aagir\Desktop\NON-EXISTENT-DIRECTORY","C:\Users\aagir\Desktop\MasterReport_29092022.xlsx")
workbookOBJ.Close
excelOBJ.Quit
msgbox returnValue
The macro (VBA function) works fine. The only thing that I am missing is within the VBS script. When I call the vba function from vbs script it runs fine but I cannot get the return value in the "returnValue" variable defined in VBS (it does not show anything). Can anyone tell what I am doing wrong? Thanks!
Based on the name sheet1 (in your VBS script), I'm assuming the f_split_master_file Function is in a Worksheet module. Move it to a standard Module and change sheet1 to (eg) Module1 and then try again.
The below code first checks if the required file is open, if it is open then use that file; if not, then open file from the path provided in the cell and read/write with that file. After completing the task, It further checks if the file path & name provided in the below cell is same or not, if same, then do nothing; if not, close the opened file without saving.
It works fine until the file path and name are same in the below cell. Throws an error when the file path and name is different in the below cell. It does not opens the file.
Not sure where am I going wrong. Can someone please help?
Asked Here - https://www.mrexcel.com/board/threads/open-file-if-not-already-open.1199858/
Asked here - https://chandoo.org/forum/threads/open-file-if-not-already-open.47763/
Sub RunQuery1()
Dim Lastrow As Long
Dim OpenBook_path, Available_File As String
Dim FileToOpen As Workbook
Dim wb As Workbook
Application.ScreenUpdating = False
Lastrow = ThisWorkbook.Sheets("Dashboard").Range("F" & Rows.Count).End(xlUp).Row
For i = 9 To Lastrow
OpenBook_path = ThisWorkbook.Sheets("Dashboard").Cells(i, 6) 'Path includes file name with extension
OpenBook_Sheet = ThisWorkbook.Sheets("Dashboard").Cells(i, 7)
OpenBook_Range = ThisWorkbook.Sheets("Dashboard").Cells(i, 8)
'Check if file is open,if open, then use open file; if not, open file from the path in the cell
Available_File = Dir(OpenBook_path) 'extracts the file name from the path
If Not wbOpen(Available_File, wb) Then Set FileToOpen = Workbooks.Open(OpenBook_path)
'open workbook from the path in the cell
With FileToOpen
'Copy range from the sheet
With Sheets(OpenBook_Sheet)
.Range(OpenBook_Range).Select 'Do something
End With
End With
'Check if Below File Path & Name are same
If ThisWorkbook.Sheets("Dashboard").Cells(i, 6) = ThisWorkbook.Sheets("Dashboard").Cells(i + 1, 6) Then
Else
FileToOpen.Close False
End If
Next i
Application.ScreenUpdating = True
End Sub
Function wbOpen(wbName As String, wbO As Workbook) As Boolean
On Error Resume Next
Set wbO = Workbooks(wbName)
wbOpen = Not wbO Is Nothing
End Function
Imagine I have a file that already has macros in it which is applied to the data. I want to split that file into multiple files based on the region column such a way that I have to keep all the macro functions in that split files also from the original file. Please tell me the way to do it in VBA.
Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,
Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
But I don't know-how to split by keeping macro functionalities from original file. please tell me how to do that.
If you want to do that in VBA, I would suggest you write code to:
Find all the values from the Region column
For each region:
Make a full copy of the original file (including the macro's)
Delete all rows which don't belong to that region
You'll have to put the macro which does the splitting and copying in a separate workbook.
I will assume that the region is in the first column of the first Sheet, and that all relevant data is on the first sheet. You will have to change that in the code to match the position in your workbook
And I assume that the original workbook is not opened. You may want to close it in your code.
Sub kopieer()
Dim macro_wb As Workbook
Dim macro_ws As Worksheet
Dim orig_wb As Workbook
Dim orig_ws As Worksheet
Dim orig_range As Range
Dim origpath As String
Dim origname As String
Dim region_wb As Workbook
Dim region_ws As Worksheet
Dim region As String
Dim region_wb_name As String
Dim region_row As Integer
Application.ScreenUpdating = False
origname = "D:\Oefen\test\Test_0.xlsm"
' Use this workbook to find the regions
Set macro_wb = ThisWorkbook
Set macro_sheet = Sheet1
macro_sheet.Cells.Clear
Set orig_wb = Application.Workbooks.Open(Filename:=origname)
origpath = orig_wb.Path
' Assuming the region is in first column of first Sheet
Set orig_ws = orig_wb.Sheets(1)
Set orig_range = orig_ws.Range([A2], [A2].End(xlDown))
orig_range.Copy (Sheet1.[A1])
orig_wb.Close
' Now we have all regions in column 1 of first sheet
Sheet1.Range([A1], [A1].End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
' loop throught the regions
For row = 1 To Sheet1.[A1].End(xlDown).row
region = Sheet1.Cells(row, 1)
' Make a full copy of the original file (including the macro's)
region_wb_name = origpath + "\" + region + ".xlsm"
FileCopy origname, region_wb_name
' Delete all rows which don't belong to that region
Set region_wb = Application.Workbooks.Open(region_wb_name)
Set region_ws = region_wb.Sheets(1)
' We are deleting rows, so we should start at the bottom
For region_row = region_ws.[A2].End(xlDown).row To 2 Step -1
If region_ws.Cells(region_row, 1).Value <> region Then
region_ws.Rows(region_row).Delete
End If
Next region_row
region_wb.Save
region_wb.Close
Next row
Application.ScreenUpdating = True
End Sub
Below is working code that is looping through files in a folder based on a user's search criteria. The folder will grow throughout the year to over 1000 files, so rather than looping through all of them every time the macro runs, I would like to add a second criteria that compares the time stamps on the files to a time stamp saved on the file as the last time it was run. LastUpdateDate is set up as variable in date format at the top of the module, and the old timestamp is saved to it at the beginning of the code.
I tried this but it left me with a run time error. Is this doable using Do While, or is there another format I need to be looking at? I also tried nesting the date comparison as an if statement under the Do While, but came up with other errors.
Do While FileName <> "" and FileDateTime(FileName) > LastUpdateDate
Working code from this section:
FileName = Dir(FolderName & "*" & MyCriterion & "*" & ".xl??")
'Loop through all matching files
Do While FileName <> ""
'Open the next matching workbook
Workbooks.Open (FolderName & FileName)
Sheets("Report Data").Select
'Call GrabTheData
GrabTheData
'Close the workbook
Workbooks(FileName).Close savechanges:=False
'Get the name of the next match in folder
FileName = Dir
Loop
End Sub
Two things:
FileDateTime
FileDateTime requires the full file path, not just the file name
Loops and Conditions
Do While (condition) stops execution of the block when (condition) is no longer true.
That is, it will stop execution as soon as (condition) is false. I don't believe this is the intended behavior.
Put an If (condition) block within the loop itself. This will loop through every workbook that matches MyCriterion, but only operate on those that match (condition).
Example (with recommendations)
Sub GrabAllData(ByVal FolderName As String, ByVal MyCriterion As String)
Dim FileName As String
Dim LastUpdateDate As Date
Dim wb As Workbook
LastUpdateDate = ThisWorkbook.Worksheets("Parameters").Range("LastUpdateDate").Value 'Named Range called LastUpdateDate on sheet "Parameters" in ThisWorkbook
'Make sure FolderName ends in a backslash
If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
'Get matching files for MyCriterion
FileName = Dir(FolderName & "*" & MyCriterion & "*" & ".xl??")
'Loop through all matching files
Do While FileName <> ""
If FileDateTime(FolderName & FileName) > LastUpdateDate Then 'FileDateTime requires the full file path, not just the file name
'Open the next matching workbook - work with the workbook directly, rather than working with ActiveWorkbook, ActiveSheet and Selections
Set wb = Workbooks.Open(FileName:=FolderName & FileName, ReadOnly:=True)
'Call GrabTheData on the workbook
GrabTheData wb
'Close the workbook
wb.Close SaveChanges:=False
End If
'Get the name of the next match in folder
FileName = Dir
Loop
Set wb = Nothing
End Sub
Sub GrabTheData(ByRef wb As Workbook)
Dim wsOut As Worksheet, wsIn As Worksheet
Set wsOut = ThisWorkbook.Worksheets("Aggregated Data") 'Worksheet called "Aggregated Data" in ThisWorkbook
Set wsIn = wb.Worksheets("Report Data")
' ### Manipulate the data and write to wsOut, no need to work with Selections ###
End Sub