Formatting outputted Excel files from Access using VBA? - excel

Here I have some VBA code that outputs a ton of files into Excel files. My question is, from this, is there anyway for it to Format the excel file a bit? What I would like to do is make the Columns bold and make the columns fit the size of the header as well.
Sub OutPutXL()
Dim qdf As QueryDef
Dim rs As DAO.Recordset
Set qdf = CurrentDb.QueryDefs("OutputStudents")
Set rs = CurrentDb.OpenRecordset("Teachers")
Do While Not rs.EOF
qdf.SQL = "SELECT * FROM Students WHERE contact='" & rs!contact & "'"
''Output to Excel
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
qdf.Name, "C:\Users\chrisjones\Documents\ProjectionsFY14\Teachers\" _
& rs!contact & ".xls", True
rs.MoveNext
Loop
End Sub

this is a quick and dirty combination of Phil.Wheeler's Code and my previous input, for me this is working. Don't forget to add Excel's Object Library in your Access-Macro.
Sub doWhatIWantTheDirtyWay()
pathToFolder = "C:\Users\Dirk\Desktop\myOutputFolder\"
scaleFactor = 0.9
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(pathToFolder)
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.path) = "xls" Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.path)
For Each sh In objWorkbook.Worksheets
If sh.UsedRange.Address <> "$A$1" Or sh.Range("A1") <> "" Then
With sh
columncount = .Cells(1, 256).End(xlToLeft).Column
For j = 1 To columncount
With .Cells(1, j)
i = Len(.Value)
.ColumnWidth = i * scaleFactor
.Font.Bold = True
End With
Next
End With
End If
Next
objWorkbook.Close True
End If
Next
objExcel.Quit
End Sub

Yes it is possible! This is hacked together from one of my codes, might need a bit of editing before it works...
'This deals with Excel already being open or not
On Error Resume Next
Set xl = GetObject(, "Excel.Application")
On Error GoTo 0
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set XlBook = GetObject(filename)
'filename is the string with the link to the file ("C:/....blahblah.xls")
'Make sure excel is visible on the screen
xl.Visible = True
XlBook.Windows(1).Visible = True
'xl.ActiveWindow.Zoom = 75
'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
'Then have some fun!
with xlsheet1
.range("A1") = "some data here"
.columns("A:A").HorizontalAlignment = xlRight
.rows("1:1").font.bold = True
end with
'And so on...

I have come across this problem a couple of times as well. As #Remou said, you will need to open excel to format xls files, this modification of your code silently opens Excel and that should get you in the right direction. Remember to add a reference to the Microsoft Excel Object Library in your VBA project.
Sub OutPutXL()
Dim qdf As QueryDef
Dim rs As DAO.Recordset
Dim xl as Excel.Application
Dim wb as Object
Dim strFile as string
Set qdf = CurrentDb.QueryDefs("OutputStudents")
Set rs = CurrentDb.OpenRecordset("Teachers")
Set xl = New Excel.Application
xl.DisplayAlerts = False
Do While Not rs.EOF
qdf.SQL = "SELECT * FROM Students WHERE contact='" & rs!contact & "'"
'Output to Excel
strFile = "C:\Users\chrisjones\Documents\ProjectionsFY14\Teachers\" & rs!contact & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, qdf.Name, strFile, True
'Start formatting'
Set wb = xl.Workbooks.Open(strFile)
With wb.Sheets(qdf.name)
'Starting with a blank excel file, turn on the record macro function'
'Format away to hearts delight and save macro'
'Past code here and resolve references'
End With
wb.save
wb.close
set wb = Nothing
rs.MoveNext
Loop
xl.quit
set xl = Nothing
End Sub

You could (depending on the number of files) make a template for each file you are outputting. In the long run if someone needs to change the formatting they can change the template which is going to be easier on you now that you don't have to sift through a bunch of excel formatting garbage. You could even let a qualified end user do it.
It's one of the biggest problems I have with excel sheets if I wrote the VBA I am responsible until I die for it. This way (in theory) they should be able to change a column, without changing how the data is outputted, just presented without you.
+1 To open the excel file itself and format it using that automation though.

Related

Access multiple exports to existing Excel workbook

I'm using Access 2013 and exporting data to an exisitng Excel 2010 workbook. I'm using the following code (passing the query, worksheet and excel filename). It all works great:
Public Function SendTQ2XLWbSheetSizeRange(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strFilePath is the name and path of the file you want to send this data into.
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Dim strPath As String
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
On Error GoTo err_handler
strPath = strFilePath
Set rst = CurrentDb.OpenRecordset(strTQName)
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Open(strPath)
ApXL.Visible = True
Set xlWSh = xlWBk.Worksheets(strSheetName)
xlWSh.Activate
xlWSh.Range("A5").Select
For Each fld In rst.Fields
ApXL.ActiveCell = fld.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
xlWSh.Range("A6").CopyFromRecordset rst
xlWSh.Range("1:1").Select
' This is included to show some of what you can do about formatting. You can comment out or delete
' any of this that you don't want to use in your own export.
With ApXL.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
ApXL.Selection.Font.Bold = True
With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
' selects all of the cells
ApXL.ActiveSheet.Cells.Select
' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
' selects the first cell to unselect all cells
xlWSh.Range("A1").Select
rst.Close
Set rst = Nothing
Exit_SendTQ2XLWbSheet:
Exit Function
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_SendTQ2XLWbSheet
End Function
Now I have a requirement to export another query to a different workbook within the same Excel file. The problem is the code above opens the Excel file, so if I then call the procedure again, it then opens an additional read-only copy of the Excel. How do I get around this? It total I will need to perform 3 exports to 3 different worksheets within 1 Excel file. Can anyone help?
I'd use three procedures. The first just identifies which file to open and which query goes on which sheet.
This will place Query1 on Sheet1, Query2 on Sheet2. It uses a ParamArray so you can add as many sheet/query pairs as you like:
Public Sub ProcessExcel()
SendToExcel "<full path to Excel file>", "Sheet1", "Query1", "Sheet2", "Query2"
End Sub
The second procedure sets a reference to Excel, opens the workbook and then starts processing the ParamArray. The sheet name is used to create a reference to the actual sheet which is then passed to the next procedure.
Public Sub SendToExcel(sFilePath As String, ParamArray ShtQry() As Variant)
Dim oXL As Object 'Ref to Excel.
Dim oWB As Object 'Ref to workbook.
Dim x As Long 'General counter
'Get or create reference to Excel.
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Err_Handle
Set oXL = CreateObject("Excel.Application")
End If
On Error GoTo Err_Handle
Set oWB = oXL.Workbooks.Open(sFilePath)
For x = LBound(ShtQry) To UBound(ShtQry) Step 2
SendTQ2XLWbSheetSizeRange oWB.worksheets(CStr(ShtQry(x))), CStr(ShtQry(x + 1))
Next x
Exit Sub
Err_Handle:
End Sub
The final procedure opens the recordset and pastes everything onto the correct sheet:
Public Sub SendTQ2XLWbSheetSizeRange(oWrkSht As Object, sTQName As String)
Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim x As Long
Set db = CurrentDb
Set rst = db.OpenRecordset(sTQName)
With oWrkSht
'Place field headings.
For x = 0 To rst.Fields.Count - 1
.cells(5, x + 1) = rst.Fields(x).Name
Next x
'Place values.
.Range("A6").CopyFromRecordset rst
End With
rst.Close
Set rst = Nothing
Set db = Nothing
End Sub
I've missed out plenty of error checks in the code - ensure the sheet exists, that the array holds sheet/query pairs and lots I haven't even considered.
Note: Not a single Select or Activate in sight - just reference the sheet.
This doesn't sound right: 'export another query to a different workbook within the same Excel file'. How about exporting the contents of different tables to one single Excel file, but placing the results of each table to a separate sheet in the same Excel file. You can easily modify the code to export queries to separate Excel sheets, instead of exporting tables.
Option Compare Database
Option Explicit
Private Sub Command0_Click()
Dim strFile As String
Dim varItem As Variant
strFile = InputBox("Designate the path and file name to export to...", "Export")
If (strFile = vbNullString) Then Exit Sub
For Each varItem In Me.List0.ItemsSelected
DoCmd.TransferSpreadsheet transferType:=acExport, _
spreadsheetType:=acSpreadsheetTypeExcel9, _
tableName:=Me.List0.ItemData(varItem), _
FileName:=strFile
Next
MsgBox "Process complete.", vbOKOnly, "Export"
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim strTables As String
Dim tdf As TableDef
' Reference: MS DAO 3.6
' Properties > All > Row Source Type = Value List
For Each tdf In CurrentDb.TableDefs
If (Left(tdf.Name, 4) <> "MSys") Then
strTables = strTables & tdf.Name & ","
End If
Next
strTables = Left(strTables, Len(strTables) - 1)
Me.List0.RowSource = strTables
End Sub
Add a ListBox to a form, and a button on the same form, and run it that way.
Thanks to everyone for their kind words and suggestions. I've gone with #Cody G. 2nd suggestions and just closed the excel file each time, so just adding
xlWBk.Close True
Set xlWBk = Nothing
ApXL.Quit
Set ApXL = Nothing
Each time.

Access - open Excel file, do some coding with It and close

I'm trying to open an Excel file from Access and do some stuff with It, but code is not stable. Sometimes It works, other times not. Here's how I do this:
Dim FilePath As String
Dim ExcelApp As Excel.Application
FilePath = "C:\Users\Lucky\Desktop\Test.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Workbooks.Open (FilePath)
With ExcelApp
'do some stuff here
End With
ExcelApp.Workbooks.Close
Set ExcelApp = Nothing
I've also noticed that once I run code, Excel starts proccess under Task Manager, that has to be killed manually in order to get code working again. Otherwise I get two types of error with Excel file:
one is that If I click Excel file, It doesn't open, It just flashes for a second and dissapears
and other is that Excel file opens in "read-only" mode...
So I reckon there is some flaw when file is closed in my code. How can I fix this ?
I can't see what's wrong with your code - maybe the path to the desktop?
This is the code I usually use - I've added another function to help choose the file. It uses late binding, so no need to set a reference to Excel - you don't get the IntelliSense and can't use Excel constants such as xlUp - you have to use the numerical equivalent.
Public Sub Test()
Dim oXLApp As Object
Dim oXLWrkBk As Object
Dim oXLWrkSht As Object
Dim vFile As Variant
Dim lLastRow As Long
vFile = GetFile()
Set oXLApp = CreateXL
Set oXLWrkBk = oXLApp.WorkBooks.Open(vFile, False)
Set oXLWrkSht = oXLWrkBk.WorkSheets(1) 'First sheet. Can also use "Sheet1", etc...
lLastRow = oXLWrkSht.Cells(oXLWrkSht.Rows.Count, "A").End(-4162).Row '-4162 = xlUp
MsgBox "Last row in column A is " & lLastRow
oXLWrkBk.Close False
oXLApp.Quit
Set oXLWrkBk = Nothing
Set oXLApp = Nothing
End Sub
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
Function GetFile(Optional startFolder As Variant = -1, Optional sFilterName As String = "") As Variant
Dim fle As Object
Dim vItem As Variant
'''''''''''''''''''''''''''''''''''''''''''
'Clear the file filter and add a new one. '
'''''''''''''''''''''''''''''''''''''''''''
Application.FileDialog(3).Filters.Clear
Application.FileDialog(3).Filters.Add "'Some File Description' Excel Files", "*.xls, *.xlsx, *.xlsm"
Set fle = Application.FileDialog(3)
With fle
.Title = "Select a file"
.AllowMultiSelect = False
If startFolder = -1 Then
.InitialFileName = CurrentProject.Path
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
I have managed to solve my problem. There is nothing wrong with code in my question, except that instead of declaring
Dim ExcelApp As Excel.Application
It's better to use
Dim ExcelApp As Object
But much bigger problem is with code that does changes in Excel, such as this line:
x = Range(Cells(1, i), Cells(Rows.Count, i).End(xlUp)).Value
And correct synthax is:
x = ExcelApp.Range(ExcelApp.Cells(1, i), ExcelApp.Cells(ExcelApp.Rows.Count, i).End(xlUp)).Value 'maybe also better to replace xlUp with -4162
So, whenever you use some code for Excel file from Access, DON'T FORGET to reference everything to Excel object. And ofcourse, before everything, a proper reference must be set in VBA console, in my case Microsoft Office 15.0 library.

Excel process not closing, Code runs every second time

I have a some command buttons that send access tables through to an excel spreadsheet and undergo some formatting and entering some formulas in them. The other command buttons work, but this one falls over at the LastRowInventory line.
I am sure its something to do with oBook but I can't quite figure out how to fix it. I think its because it is attempting to get an object it has already got. It runs smoothly every second time, but does not close the excel process. My attempts at resolving this over the last couple hours have not worked.
The error I have been getting is as follows:
Run-time error '462': The remote server machine does not exist or is unavailable
Any help is appreciated. I believe it is a simple fix but just can't quite get it, I'm pretty new to programming. The code is below.
Private Sub INVENTORYLIST_Click()
DTable = InputBox("Input Table Name")
'****************************TRANSFER TO EXCEL********************************
Dim strWorksheetPathTable As String
strWorksheetPathTable = "O:\GData\Downstream_LNG\Data Mgmt\CEDA\Reports\" & DTable & "\" & DTable & ".xls"
DoCmd.TransferSpreadsheet transfertype:=acExport, _
spreadsheettype:=acSpreadsheetTypeExcel12, _
TableName:=("" & DTable & "_INVENTORY LIST"), FileName:=strWorksheetPathTable, _
hasfieldnames:=True, _
Range:="InventoryList"
'****************************FORMAT INVENTORY SHEET***********************************
Dim xlApp As Object
Dim xlWB As Object
Set xlApp = CreateObject("Excel.Application")
Dim oBook As Excel.Workbook
Dim InventoryListSheet As Excel.Worksheet
Dim SummarySheet As Excel.Worksheet
Set xlWB = xlApp.Workbooks.Open("" & strWorksheetPathTable & "")
Set oBook = GetObject("" & strWorksheetPathTable & "")
Set InventoryListSheet = oBook.Sheets("InventoryList")
Set SummarySheet = oBook.Sheets("Summary")
With xlWB
With InventoryListSheet
'Some Spreadesheet Formatting in here
End With
End With
'****************************CREATE OE STATUS BREAKDOWN CALCULATIONS ON SUMMARY SHEET**********************
Dim LastRowInventory As Long
LastRowInventory = oBook.Sheets("InventoryList").Range("A" & Rows.Count & "").End(xlUp).Row
With xlWB
With SummarySheet
'Some Spreadsheet Formulas here
End With
End With
'*********************************ORDER WORKSHEETS*************************************
With xlWB
.Sheets("InventoryList").Select
.Sheets("InventoryList").Move Before:=oBook.Sheets(1)
.Sheets("Summary").Select
.Sheets("Summary").Move Before:=oBook.Sheets(1)
End With
If Not SummarySheet Is Nothing Then
Set SummarySheet = Nothing
End If
If Not InventoryListSheet Is Nothing Then
Set InventoryListSheet = Nothing
End If
If Not oBook Is Nothing Then
Set oBook = Nothing
End If
If Not xlWB Is Nothing Then
xlWB.Save
xlWB.Close
Set xlWB = Nothing
End If
If Not xlApp Is Nothing Then
xlApp.Quit
Set xlApp = Nothing
End If
DoCmd.SetWarnings True
MsgBox ("INVENTORY SHEET HAS BEEN CREATED.")
End Sub
Try this:
LastRowInventory = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Or if that doesn't work try:
LastRowInventory = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Does this help you?
EDIT:
LastRowInventory = InventoryListSheet.Range("A" & InventoryListSheet.Rows.Count & "").End(xlUp).Row
By specifying the sheet that the rows are to be counted on the issue is fixed.

MID function does nothing when run from VBS

I have been trying all day to do something pretty simple. I am an absolute newbie with VB so I am sure I've missed something.
I have been trying to use MID to split up the numbers in a column on a spreadsheet.
Here is what I have so far (I have been trying to do only one to make sure it works):
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open("C:\Documents and Settings\<username>\Desktop\New.csv")
Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Activate
sub_str = Mid(A1, 1, 4)
So the application opens, the worksheet is active, then... nothing. No error or anything. It's like it literally stops there and ignores the last line altogether. The numbers that I want to split look like the below in Excel. They are just dates that are backwards, hence the wanting to split, so I can separate and put it the right way round.
20140101
20140127
20140303
20140310
20140310
20140310
20140310
20140418
20140419
Any help is very appreciated!
Try this:
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\USER\Desktop\new1.csv")
Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Activate
rowCount=objWorksheet.usedrange.rows.count
Set rngA=objWorksheet.Range("A1:A" & rowCount)
'Set rngB=rngA.offset(,1) 'objWorksheet.Range("B1")
with objWorksheet
for each cell in rngA
sub_strY = Mid(cell.value, 1, 4)
sub_strM=Mid(cell.value, 5, 2)
sub_strD=Mid(cell.value, 7, 2)
'msgbox sub_strY
'msgbox sub_strM
'msgbox sub_strD
strDate=sub_strD & "/" & sub_strM & "/" & sub_strY
msgbox strDate
'cell.offset(,1).value=strDate ''to another column
cell.value=strDate ''to overwrite
next
end with
You can use Mid in vbscript. The problem is not there. The problem is in A1 in the line sub_str = Mid(A1, 1, 4).
A1 has been treated like a variable. It's always best to work with objects. Also if you want 20140419 to be changed to 04192014 then you actually do not need Mid. You can use Left and Right for this.
I am assuming that the data is in the format yyyymmdd and you want output as mmddyyyy. If you want the output as ddmmyyyy, then you will have to use Mid. like this
sDate = Right(.Range("A" & i).Value, 2) & _
Mid(.Range("A" & i).Value, 5, 2) & _
Left(.Range("A" & i).Value, 4)
Is this what you are trying?
Const xlUp = -4162
Dim oXLApp, oXLwb, oXLws
Dim lRow, i
Dim sFile, sDate
'~~> Change this to the relevant file
sFile = "C:\Users\Siddharth Rout\Desktop\book1.xlsx"
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Hide Excel
oXLApp.Visible = False
'~~> Open files
Set oXLwb = oXLApp.Workbooks.Open(sFile)
'~~> Set the worksheet you want to work with
Set oXLws = oXLwb.Sheets(1)
'~~> work with the worksheet
With oXLws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
'~~> 20140101 becomes 01012014. If the Col A is formatted
'~~> as number then the leading `0` will disappear as
'~~> shown in the screenshot below
sDate = Right(.Range("A" & i).Value, 4) & Left(.Range("A" & i).Value, 4)
.Range("A" & i).Value = sDate
Next
End With
'~~> Close and save
oXLwb.Close (True)
'~~> CLEANUP (VERY IMPROTANT)
Set oXLws = Nothing
Set oXLwb = Nothing
oXLApp.Quit
Set oXLApp = Nothing
MsgBox "DONE" 'OR wscript.echo "Done"
Screenshots:
Before
After
The Mid function is not a VBscript function but a VBA function therefore if anyway this might work:
objExcel.Mid([A1], 1, 4)
instead of this:
Mid(A1, 1, 4)
If this does not work a you need to run Excel then try putting all the logic in the Excel function and executing it from VBscript if needed (example below):
RunMacro
Sub RunMacro()
dim xl
Set xl = CreateObject("Excel.application")
Dim xlBook
Dim sCurPath
path = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
Set xl = CreateObject("Excel.application")
Set xlBook = xl.Workbooks.Open(path & "\Book1.xlsm", 0, True)
xl.Application.Visible = False
xl.DisplayAlerts = False
xl.Application.run "Book1.xlsm!Module.MyMacro"
xl.ActiveWindow.close
Set xlBook = Nothing
xl.Quit
Set xl = Nothing
End Sub

Unable to Copy huge volume of data in Excel in VbScript

I'm working in VbScript to Copy all the worksheets of all the files in a folder in a single workbook and save it.
I have 4 workbooks. Each contains 1 worksheet.
worksheet 1 = 1 MB, worksheet 2 = 19 MB, worksheet 3 = 48 MB and worksheet 4 = 3 MB
The worksheets are copied properly in all the sheets except worksheet 3.
In worksheet 3, only 1/2 of the data is copied. What is the issue behind it?
Please find the code below. Thanks is advance.
'~~> Change Paths as applicable
Dim objExcel, objWorkbook, Temp, wbSrc
Dim objShell, fol, strFileName, strDirectory, extension, Filename
Dim objFSO, objFolder, objFile
strFileName = "C:\Users\ARUN\Desktop\LD.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
extension = "xlsx"
strDirectory = InputBox("Enter the Folder Path:","Folder Path")
'strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)
'For loop to count the number of files starts
For Each objFile In objFolder.Files
if LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) then
counter = counter + 1
'Get the file name
FileName = objFile.Name
'Temp = msgbox(FileName,0,"File Name" )
end if
Next
'For loop to count the number of files ends
Temp = "There are " & counter & " '. " & extension & "' files in the " & strDirectory & " folder path."
Set objShell = Wscript.CreateObject("Wscript.Shell")
objShell.Popup Temp,2,"Files Count"
For Each objFile In objFolder.Files
If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
Filename = objFile.Name
Filename = strDirectory & "\" & Filename
Set wbSrc = objExcel.Workbooks.Open(Filename)
wbSrc.Sheets(1).Copy objWorkbook.Sheets(objWorkbook.Sheets.Count)
wbSrc.Close
End If
Next
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit
objShell.Popup "All The Files Are Merged!!!",2,"Success"
Set fol = objFSO.GetFolder(strDirectory)
FolderName = InputBox("Enter the Folder Path:","Folder Path")
FolderNameMove = FolderName & "\"
objFSO.CopyFile strFileName, FolderNameMove
Like I said, I am not sure what could be the reason as you are not getting an error. Possibly a memory issue? However as I suggested in comments above, you can copy the cells across as mentioned in this LINK Way 2
Also like I mentioned, it is not necessary that the the new workbook that is created will have 3 sheets. It all depends on the Excel settings. If you see Excel Options, you will notice that the default setting is 3
What if a user has set it to 2? Then your code
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
will fail on the 3rd line as there is no sheet by that name. Also under different, regional settings, the names of the sheet might not be Sheet1, Sheet2 or Sheet3. We might be tempted to use On Error Resume Next to delete the sheets. For example
On Error Resume Next
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
On Error GoTo 0
or
On Error Resume Next
objWorkbook.sheets(1).Delete
objWorkbook.sheets(2).Delete
objWorkbook.sheets(3).Delete
On Error GoTo 0
This will work but then what if the default setting is 5. What happens to the additional 2 sheets. So the best approach is
To delete all sheets except 1 sheet as Excel will not let you delete that
Add new sheets. The trick here is that you add all the new sheets to the end
Once you are done, simply delete the 1st sheet.
Try this (TRIED AND TESTED)
Dim objExcel, objWorkbook, wbSrc, wsNew
Dim strFileName, strDirectory, extension, FileName
Dim objFSO, objFolder, objFile
strFileName = "C:\Users\Siddharth Rout\Desktop\LD.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
'~~> This will delete all sheets except the first sheet
'~~> We can delete this sheet at the end.
objExcel.DisplayAlerts = False
On Error Resume Next
For Each ws In objWorkbook.Worksheets
ws.Delete
Next
On Error GoTo 0
objExcel.DisplayAlerts = True
extension = "xlsx"
strDirectory = "C:\Users\Siddharth Rout\Desktop\Excel Merger Project"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)
For Each objFile In objFolder.Files
If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
FileName = objFile.Name
FileName = strDirectory & "\" & FileName
Set wbSrc = objExcel.Workbooks.Open(FileName)
'~~> Add the new worksheet at the end
Set wsNew = objWorkbook.Sheets.Add(, objWorkbook.Sheets(objWorkbook.Sheets.Count))
wbSrc.Sheets(1).Cells.Copy wsNew.Cells
wbSrc.Close
End If
Next
'~~> Since all worksheets were added in the end, we can delete sheet(1)
'~~> We still use On error resume next becuase what if no sheets were added.
objExcel.DisplayAlerts = False
On Error Resume Next
objWorkbook.Sheets(1).Delete
On Error GoTo 0
objExcel.DisplayAlerts = True
'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit
Set wsNew = Nothing
Set wbSrc = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing

Resources