I am very much a novice when it comes to vba programming, and as such have not been able to find/figure out a solution to my problem.
I have a vba script that runs through a button in an access form (excerpt below) that does a calculation in excel, for approximately 30,000 records (Inventory List worksheet). Further to this, the "Data1" worksheet has 1,000,000 records and the "Data2" worksheet has approximately 100,000 records. The calculation checks for how many pieces of information a "tag" requires and how many pieces of information the "tag" currently has in our database, and calculates a decimal value for completeness.
This all results in 100% CPU usage when computing. I was wondering if anyone would have some pointers on how to improve the calculation so as to improve its running speed?
Thanks in advance.
Private Sub BUILD_INVENTORY_LIST_Click()
DoCmd.SetWarnings False
'Note: DTable is a variable entered earlier in the coding
Dim strWorksheetPathTable As String
strWorksheetPathTable = "O:\GData\POC\DataMgmt\Reports\" & DTable & "\" & DTable & ".xls"
Dim xlApp As Object
Dim xlWB As Object
Dim oBook As Excel.Workbook
Dim InventoryListSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("" & strWorksheetPathTable & "")
Set oBook = GetObject("" & strWorksheetPathTable & "")
Set InventoryListSheet = oBook.Sheets("InventoryList")
Dim NumberofTags As String
NumberofTags = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count
If Len(Sheets("Data1").Name) > 0 Then
With xlWB
With InventoryListSheet
.Range("O2").Formula = "=(COUNTIFS(Data1!A:A,A2,Data1!G:G,""Y"",Data1!E:E,""<>"")/(COUNTIFS(Data1!A:A,A2,Data1!G:G,""Y"")))"
.Range("O2:O" & NumberofTags & "").FillDown
End With
End With
End If
If Len(Sheets("Data2").Name) > 0 Then
With xlWB
With InventoryListSheet
.Range("P2").Formula = "=(COUNTIFS(Data2!A:A,A2,Data2!G:G,""Y"",Data2!E:E,""<>"")/(COUNTIFS(Data2!A:A,A2,Data2!G:G,""Y"")))"
.Range("P2:P" & NumberofTags & "").FillDown
End With
End With
End If
xlWB.Save
xlWB.Close
DoCmd.SetWarnings True
End Sub
Have you tried this:
http://blogs.office.com/2009/03/12/excel-vba-performance-coding-best-practices/
or similarly this:
http://www.cpearson.com/excel/optimize.htm
where relevant.
Related
I'm working on a database that will compile 4 recordsets together in order to output 3 excel worksheets into a single workbook for each workcenter or Office Symbol. This will be updated weekly and new workbooks produced at each update.
I've managed to stumble my way into creating the workbooks the way I want them. However, saving the files has become an issue. The beginning of this sub creates a folder using today's date. Everything following creates the individual reports. The issue comes when I attempt to use the "wb.Saveas". Instead of saving the reports with the name from the "Do While Not" in the created folder, it saves it using today's date and the "Do While Not" output (See attached images).
I also have an issue with the Select Queries (AD1, PT1 and LV1) not giving me consistent results. Instead of filtering to only 1 Office Symbol, some of the time I get 3 or 4 on one excel output.
Thanks in advance for help with this.
Please excuse my lack of consistency with coding. I'm stumbling my way through this and I don't know the proper formatting etiquette.
incorrect naming format
Private Sub Export_Button_Click()
Dim sFolderName As String, sFolder As String
Dim sFolderPath As String
sFolder = "C:\Users\1023491733A\Desktop\TEST\"
sFolderName = Format(Now, "dd MMM yyyy")
sFolderPath = "C:\Users\1023491733A\Desktop\TEST\" & sFolderName
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolderPath) Then
MsgBox "Folder already exists with today's date!", vbInformation, "VBAF1"
Else
MkDir sFolderPath
MsgBox "Folder has created with today's date: " & vbCrLf & vbCrLf & sFolderPath, vbInformation, "VBAF1"
End If
Dim db As DAO.Database
Set db = CurrentDb
Dim OS As DAO.Recordset
Set OS = db.OpenRecordset("Office_Symbols")
Dim AD As DAO.Recordset
Set AD = db.OpenRecordset("XLS-Airfield")
Dim PT As DAO.Recordset
Set PT = db.OpenRecordset("XLS-Fitness")
Dim LV As DAO.Recordset
Set LV = db.OpenRecordset("XLS-Leave")
Dim xl
Set xl = CreateObject("Excel.Application")
Dim wb As Object
Set wb = xl.Workbooks.Add("C:\Users\1023491733A\Desktop\TEST\Template.xlsx")
Dim wr As Object
Set wr = wb.Worksheets("Airfield")
Dim ws As Object
Set ws = wb.Worksheets("Fitness")
Dim wt As Object
Set wt = wb.Worksheets("Leave")
Do While Not OS.EOF
Dim AD1 As DAO.Recordset
Set AD1 = db.OpenRecordset("SELECT [XLS-Airfield].* FROM [XLS-Airfield] WHERE ([XLS-Airfield].OFFICE_SYMBOL)='" & OS.Fields(0) & "';")
Dim PT1 As DAO.Recordset
Set PT1 = db.OpenRecordset("SELECT [XLS-Fitness].* FROM [XLS-Fitness] WHERE ([XLS-Fitness].OFFICE_SYMBOL) ='" & OS.Fields(0) & "';")
Dim LV1 As DAO.Recordset
Set LV1 = db.OpenRecordset("SELECT [XLS-Leave].* FROM [XLS-Leave] WHERE ([XLS-Leave].OFFICE_SYMBOL) ='" & OS.Fields(0) & "';")
wr.Select
wr.Range("A1").Select
For Each fld In AD1.Fields
xl.ActiveCell = fld.Name
xl.ActiveCell.Offset(0, 1).Select
Next
AD1.MoveFirst
wr.Cells(2, 1).CopyFromRecordset AD1
'Break
ws.Activate
ws.Range("A1").Select
For Each fld In PT1.Fields
xl.ActiveCell = fld.Name
xl.ActiveCell.Offset(0, 1).Select
Next
PT1.MoveFirst
ws.Cells(2, 1).CopyFromRecordset PT1
'Break
wt.Activate
wt.Range("A1").Select
For Each fld In LV1.Fields
xl.ActiveCell = fld.Name
xl.ActiveCell.Offset(0, 1).Select
Next
LV1.MoveFirst
wt.Cells(2, 1).CopyFromRecordset LV1
Dim sFileName As String
sFileName = OS.Fields(0)
wb.SaveAs sFolderPath & sFileName
Set AD1 = Nothing
Set PT1 = Nothing
Set LV1 = Nothing
OS.MoveNext
Loop
OS.Close
wr.Rows("1:1").Font.Bold = True 'Row 1 Bold
wr.Cells.EntireColumn.AutoFit 'Autofit all the columns
ws.Rows("1:1").Font.Bold = True 'Row 1 Bold
ws.Cells.EntireColumn.AutoFit 'Autofit all the columns
wt.Rows("1:1").Font.Bold = True 'Row 1 Bold
wt.Cells.EntireColumn.AutoFit 'Autofit all the columns
Set OS = Nothing
Set AD = Nothing
Set PT = Nothing
Set LV = Nothing
End Sub
I have solved my issue. I'm not sure if it's the best solution but here are the changes I made.
Dim the objects was moved into the the Do While Not loop and each was set to nothing before the OS.MoveNext.
Do While Not OS.EOF
Dim xl As Object
Set xl = CreateObject("Excel.Application")
Dim wb As Object
Set wb = xl.Workbooks.Open("C:\Users\1023491733A\Desktop\TEST\Template.xlsx")
Dim wr As Object
Set wr = wb.Worksheets("Airfield")
Dim ws As Object
Set ws = wb.Worksheets("Fitness")
Dim wt As Object
Set wt = wb.Worksheets("Leave")
I added a backslash to sFolderName as below which helped. And for some reason unknown to me, using two variables ("sfolderpath" and "OS.Fields(0)) would always give a run-time 1004 error. But inserting a constant between them seems to fix this issue but again I'm not sure why.
sFolderName = (Format(Now, "dd MMM yyyy") & "\")
Dim sfilename As String
sfilename = sFolderPath & "TEST" & OS.Fields(0)
wb.SaveAs sfilename
I understand the first fix since the loop was using the excel workbook from the previous iteration. But I can't wrap my head around why the sFileName fix worked. If anyone can explain this I would greatly appreciate it.
I have already spent too many hours looking for the right answer and every which way I try it doesn't work the way I want it to.
I receive the "Application or Object defined error" referencing the Excel file when I run the following. It compiles just fine, so I am not sure where I went wrong. I need it to pull data from two different places on an Excel sheet, place them in specific defined labels in a Word doc, save it with custom name and continue to do so until the end of the list in Excel. Data begins in A1 and B1 respectively.
Dim oXL As Object
Dim oWB As Object
Dim exWb As String
Dim oSheet As Object
Dim bStartExcel As Boolean
Dim objDoc As Object
Dim fcount As Long
Dim iRow As Integer
exWb = "C:\Documents\Waivers_needed_0926_Take2.xlsx"
On Error Resume Next
'If Excel running use it
Set oXL = GetObject(, "Excel.application")
If Err.Number <> 0 Then 'If Excel isn't running then start it
bStartExcel = True
Set oXL = CreateObject("Excel.Application")
End If
On Error GoTo Err_Handler
'Open the workbook
Set oWB = oXL.Workbooks.Open(FileName:=exWb)
'Process the worksheet
Set oSheet = oXL.ActiveWorkbook.Worksheets(4)
For iRow = 1 to 100
With oSheet.Cells(iRow, 0)
ActiveDocument.Amt_Paid.Caption = .Value
End With
With oSheet.Cells(iRow, 1)
ActiveDocument.Payee.Caption = .Value
End With
'Save Word Document with new name
fcount = fcount + 1
With ActiveDocument
.SaveAs FileName:="C:\Documents\Waivers\" & Split(ActiveDocument.Name, ".")(0) & "_" & Format(Now(), "YYYYMMDD") & "_" & fcount & ".doc"
End With
Next iRow
Exit Sub
I'm exporting to Excel and I need to insert numbers in front of cells that allready have numbers in It. Here is my full code:
Private Sub cmdExport_Click()
Dim Results As Recordset
Dim Numbering As Integer
Dim FileName As String
Dim FilePath As String
Dim wb As Excel.Workbook
Dim XcelFile As Excel.Application
FileName = "TEST" & Format(Date, "dd/mm/yyyy") & ".xlsx"
FilePath = CurrentProject.Path & "\" & FileName
Set XcelFile = New Excel.Application
Set wb = XcelFile.Workbooks.Add
Set Results = Forms![MyForm].Form.RecordsetClone
With wb
XcelFile.ScreenUpdating = False
For Numbering = 0 To Results.Fields.Count - 1
XcelFile.Cells(1, Numbering + 1).Value = Results.Fields(Numbering).Name
Next Numbering
Results.MoveFirst
XcelFile.Range("A2").CopyFromRecordset Results
For Each cell In XcelFile.Range("A:A")
cell.Value = "100" & cell.Value
Next cell
.SaveAs FileName:=FilePath, FileFormat:=51
XcelFile.ScreenUpdating = True
End With
wb.Close
Set XcelFile = Nothing
End Sub
As you see, I have tried with this:
For Each cell In XcelFile.Range("A:A")
cell.Value = "100" & cell.Value
Next cell
But, unfortunally, nothing happens. How could I solve this?
For Each cell In XcelFile.Range("A:A")
should be
Dim sh As Excel.Worksheet
Set sh = wb.ActiveSheet
For Each cell In sh.Range("A:A")
me thinks.
This applies for all other places where you have XcelFile.Cells now, change them to sh.Cells.
Note:
Dim XcelFile As Excel.Application
is a really really confusing name, IMHO.
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.
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.