|
VBA Tips - ScreenUpdating - Make your code run faster
Video | Similar Helpful Excel Resources
ExcelExperts.com brings you training video on: VBA Tips - ScreenUpdating - Make your code run faster
Got a Question? Ask it Here in the Forum.
Similar Helpful Excel Resources
The following code takes over a minute to perform. Not sure why...is there anyway to make it faster? I have lowered the column range to the smallest amount of cells as possible.
Bascially each loop is the same except for a different column.
thanks!
Latigo
Code:
Sub Test()
Dim r As Range
Dim c As Range
'Set r = Range("C5:C100")
For Each c In Range("C5:C75")
If Not IsEmpty(c.Value) Then
On Error Resume Next
c.Value = DateValue("1 " & c.Value)
c.NumberFormat = "mmm-yy"
If Err Then
c.Value = ""
End If
End If
Next c
For Each c In Range("E5:E55")
If Not IsEmpty(c.Value) Then
On Error Resume Next
c.Value = DateValue("1 " & c.Value)
c.NumberFormat = "mmm-yy"
If Err Then
c.Value = ""
End If
End If
Next c
End Sub
EDIT: added code tags and removed about 15 identical loops for different ranges - Moderator
Hi All,
I need to make the below code faster, any ideas?
VB:
Dim myWorksheet As Worksheet
Dim myWorksheetName As String
Dim count As Long
Dim temp As String
Dim count2 As Long
If ComboBox1.value = "" Or ComboBox2.value = "" Then
MsgBox ("Please select Month or Branch")
Exit Sub
End If
temp = ComboBox2.value
If temp = "All" Then
temp = "*"
End If
myWorksheetName = ComboBox1.value
'check if exsists
'call SheetExists
If SheetExists(ComboBox1.value) = True Then
count = Sheets(myWorksheetName).Range("A1").CurrentRegion.Rows.count
Worksheets(myWorksheetName).Range("A1:P" & count).AutoFilter _
field:=4, Criteria1:=temp
Worksheets("Sheet1").Range("A1:P2").Copy _
Destination:=Worksheets("Sheet3").Range("A1")
Worksheets(myWorksheetName).Range("A3:M" & count).Copy _
Destination:=Worksheets("Sheet3").Range("A3")
count2 = Sheets("Sheet3").Range("A1").CurrentRegion.Rows.count
count23 = count2 + 1
Sheets("Sheet3").Range("K" & count23).value = "Total"
Sheets("Sheet3").Range("L" & count23).value = "=SUM(L3:L" & count2 & ")"
Sheets("Sheet3").Range("M" & count23).value = "=SUM(M3:M" & count2 & ")"
With Sheets("Sheet3").PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.PrintArea = ""
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.92)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Me.Hide
Application.WindowState = xlMaximized
Sheets("Sheet3").Range("A1:M" & count23).PrintPreview
Application.WindowState = xlMinimized
Me.Show
Worksheets(myWorksheetName).AutoFilterMode = False
Sheets("Sheet3").Range("A1:P" & count23).value = ""
Sheets("Sheet3").Range("A1:P2").UnMerge
ThisWorkbook.Save
Else
MsgBox ("No Data For That Month Please Change")
Exit Sub
End If
If you like these VB formatting tags please consider sponsoring me in support of injured Royal Marines
Hi...Is there any way to make this code run faster?
Code:
Sub InteriorCellColor()
'
'If ActiveCell.Interior.ColorIndex = 3 Then MsgBox "3"
MsgBox ActiveCell.Interior.ColorIndex & "=Index Color No"
MsgBox ActiveCell.Interior.Color & "=Interior Color No"
MsgBox ActiveCell.Font.Color & "=Font Color"
End Sub
Sub EvalColor()
Dim c As Variant, acv As Variant, cd As String, cnt As Integer
cnt = 1
'Do Until cnt = 322
Do Until cnt = Int(Range("A4").Value + 1) 'a4 hows number of current records
SendKeys "~", True
c = ActiveCell.Offset(0, -1).Interior.ColorIndex
acv = ActiveCell.Value
If c > 0 Then
Select Case c
Case Is = 4
cd = "FV" 'full day visit
Case Is = 44
cd = "HV" 'half day visit
Case Is = 33
cd = "FL" 'full day launch
Case Is = 39
cd = "HL" 'half day launch
Case Is = 54
cd = "FB" 'missed visit banked
Case Is = 54
cd = "HB" 'missed visit banked
Case Is = 3
cd = "FR" 'missed visit refund
Case Is = 3
cd = "HR" 'missed visit refund
Case Is = 6
cd = "CQ" 'dealer convert to monthly
Case Is = 15
cd = "CM" 'dealer convert to quarterly
Case Is = 5
cd = "NO" 'dealer not open
Case Is = 50
cd = "FP" 'planning meeting
Case Is = 38
cd = "FG" 'region meeting
Case Else
cd = ""
End Select
acv = cd & " " & acv
ActiveCell.Value = acv
End If
cnt = cnt + 1
Loop
c = ""
acv = ""
cd = ""
End Sub
Sub EvalDateOnlyColumn3()
Dim c As Variant, acv As Variant, cd As String, cnt As Integer
cnt = 1
'Do Until cnt = 322
Do Until cnt = Int(Range("A4").Value + 1) 'a4 hows number of current records
SendKeys "~", True
c = ActiveCell.Offset(0, -3).Interior.ColorIndex
acv = ActiveCell.Value
If acv "" Then
If c > 0 Then
Select Case c
Case Is = 4
cd = "FV" 'full day visit
Case Is = 44
cd = "HV" 'half day visit
Case Is = 33
cd = "FL" 'full day launch
Case Is = 39
cd = "HL" 'half day launch
Case Else
cd = ""
End Select
acv = cd & " " & acv
ActiveCell.Value = acv
End If
End If
cnt = cnt + 1
Loop
c = ""
acv = ""
cd = ""
End Sub
Sub EvalDateOnlyColumn4()
Dim c As Variant, acv As Variant, cd As String, cnt As Integer
cnt = 1
'Do Until cnt = 322
Do Until cnt = Int(Range("A4").Value + 1) 'a4 hows number of current records
SendKeys "~", True
c = ActiveCell.Offset(0, -4).Interior.ColorIndex
acv = ActiveCell.Value
If acv "" Then
If c > 0 Then
Select Case c
Case Is = 4
cd = "FV" 'full day visit
Case Is = 44
cd = "HV" 'half day visit
Case Is = 33
cd = "FL" 'full day launch
Case Is = 39
cd = "HL" 'half day launch
Case Else
cd = ""
End Select
acv = cd & " " & acv
ActiveCell.Value = acv
End If
End If
cnt = cnt + 1
Loop
c = ""
acv = ""
cd = ""
End Sub
Sub EvalDateOnlyColumn2()
Dim c As Variant, acv As Variant, cd As String, cnt As Integer
cnt = 1
'Do Until cnt = 322
Do Until cnt = Int(Range("A4").Value + 1) 'a4 hows number of current records
SendKeys "~", True
c = ActiveCell.Offset(0, -2).Interior.ColorIndex
acv = ActiveCell.Value
If acv "" Then
If c > 0 Then
Select Case c
Case Is = 4
cd = "FV" 'full day visit
Case Is = 44
cd = "HV" 'half day visit
Case Is = 33
cd = "FL" 'full day launch
Case Is = 39
cd = "HL" 'half day launch
Case Else
cd = ""
End Select
acv = cd & " " & acv
ActiveCell.Value = acv
End If
End If
cnt = cnt + 1
Loop
c = ""
acv = ""
cd = ""
End Sub
Sub SetDealerColor()
Dim c As Variant, acv As Variant, cd As String, cnt As Integer, avcr As String, acvl As String
'find inconsistent dashes
Columns("J:J").Select
Selection.Replace What:=" - ", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("J5").Select
cnt = 1
'Do Until cnt = 601
Do Until cnt = Int(Range("A4").Value + 1) 'a4 holds number of current records
SendKeys "~", True
ActiveCell.Value = UCase(ActiveCell.Value)
acv = ActiveCell.Value
acvr = Right(ActiveCell.Value, 1)
acvl = Left(ActiveCell.Value, 1)
If acvl acvr Then
acv = acvl & acvr
Select Case acv
Case Is = "LM" 'dealer goes to monthly
ActiveCell.Offset(0, -3).Interior.ColorIndex = 15
ActiveCell.Interior.ColorIndex = 15
Case Is = "QM" 'dealer goes to quarterly
ActiveCell.Offset(0, -3).Interior.ColorIndex = 15
ActiveCell.Interior.ColorIndex = 15
Case Is = "LQ" 'dealer goes to quarterly
ActiveCell.Offset(0, -3).Interior.ColorIndex = 6
ActiveCell.Interior.ColorIndex = 6
Case Is = "MQ" 'dealer goes to quarterly
ActiveCell.Offset(0, -3).Interior.ColorIndex = 6
ActiveCell.Interior.ColorIndex = 6
Case Else
acv = ""
ActiveCell.Interior.Color = 16777215
ActiveCell.Font.Color = 0
End Select
End If
cnt = cnt + 1
Loop
c = ""
acv = ""
cd = ""
End Sub
Sub SetCloseColor()
Dim c As Variant, acv As Variant, cd As String, cnt As Integer
'find inconsistent dashes
Range("I5").Select
cnt = 1
'Do Until cnt = 601
Do Until cnt = Int(Range("A4").Value + 1) 'a4 holds number of current records
SendKeys "~", True
ActiveCell.Value = UCase(ActiveCell.Value)
acv = ActiveCell.Value
Select Case acv
Case Is = "X" 'dealer closed
ActiveCell.Interior.ColorIndex = 5
ActiveCell.Font.ColorIndex = 2
Selection.Font.Bold = True
Case Else
acv = ""
ActiveCell.Interior.Color = 16777215
ActiveCell.Font.Color = 0
End Select
cnt = cnt + 1
Loop
c = ""
acv = ""
cd = ""
End Sub
Sub CodeAllMonths()
Dim rc As Variant, cc As Variant, acv As String, cur As Variant, ch As String
'STATUS_________________________________________________________
Application.DisplayStatusBar = True
Application.StatusBar = "Updating worksheet.........................................................."
MsgBox "Please Stand By While Updating"
If ActiveSheet.FilterMode = True Then 'find if filter is on
With ActiveSheet 'find filter name
If .AutoFilterMode Then
With .AutoFilter.Filters(4)
If .On Then c1 = .Criteria1
ActiveSheet.AutoFilterMode = False 'turn filter off
End With
End If
End With
Else
ActiveSheet.AutoFilterMode = False 'turn filter off
End If
'reset total column counts and add more if new dealers are added
Range("BU4:CM4").Select
Selection.Copy
Range("BU6:CM" & Range("A4").Value + 5 & "").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'reset launch days and add more if new if new dealers are added
Range("K4").Select
Selection.Copy
Range("K6:K" & Range("A4").Value + 5 & "").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'reset blue divider columns
Range( _
"CN:CN,CH:CH,CB:CB,BZ:BZ,BT:BT,BO:BO,BJ:BJ,BE:BE,AZ:AZ,AU:AU,AP:AP,AK:AK,AF:AF,AA:AA,V:V,Q:Q,L:L" _
).Select
Range("L1").Activate
Selection.ColumnWidth = 0.6
'rc = row count, cc = column count, cur = current color
Range("A5").Select
'start at the first Jan heading cell
Cells.Find(What:="jan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
).Activate
'move left to first blue divider cell
SendKeys "{LEFT}", True
rc = 1
cc = 0
Dim scc As Variant ' sheet column count
'If Right(Range("A3").Value, 9) = "Scheduled"
' scc = 68
'Else
' scc = 81
'End If
Do Until cc = 81
ch = Left(ActiveCell.Offset(rowOffset:=-4, columnOffset:=cc).Value, 1)
rc = 1
'Do Until rc = 601
Do Until rc = Int(Range("A4").Value + 1) 'a4 holds number of current records
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value = UCase(ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value)
acv = Left(ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value, 2)
cur = ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color
'_______________________________________________________________
If cc > 60 Then 'format total columns
Select Case ch 'bold and font = red where days are still due
Case Is = "D" 'Days Due
If ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value > 0 Then
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Bold = True
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 16777164
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
End If
Case Is = "V" 'Visit totals
If ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value > 0 Then
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Bold = True
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 8421376
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
End If
Case Is = "B" 'Banked totals
If ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value > 0 Then
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Bold = True
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 6697881
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
End If
Case Is = "R" 'Refund totals
If ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value > 0 Then
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Bold = True
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 255
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
End If
End Select
End If
'_______________________________________________________________
Select Case acv
Case Is = "FV" 'full day visit
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 65280
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "HV" 'half day visit
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 10079487
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "FL" 'full day launch
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 16764057
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "HL" 'half day launch
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 16751052
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "FB" 'missed visit banked
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 6697881
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
Case Is = "HB" 'missed visit banked
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 6697881
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
Case Is = "FR" 'missed visit refund
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 255
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
Case Is = "HR" 'missed visit refund
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 255
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
Case Is = "CQ" 'dealer convert to monthly
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 65535
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "CM" 'dealer convert to quarterly
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 12632256
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "NO" 'dealer not open
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 16711680
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Is = "FP" 'dealer convert to quarterly
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 6723891
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16777215
Case Is = "FG" 'dealer not open
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 13408767
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
Case Else
If ch = "" Then
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 16764057
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 16763904
Else
If cc < 60 Then 'turn blank cell to white with black text
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 16777215
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Color = 0
'ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).ClearContents
End If
End If
End Select
rc = rc + 1
Loop
cc = cc + 1
Loop
acv = ""
'hide rows 1 and 4 these are used for calculations and uploads
Rows("1:1").Select
Selection.EntireRow.Hidden = True
Rows("4:4").Select
Selection.EntireRow.Hidden = True
'reset column widths
Columns("G:CO").Select
Columns("G:CO").EntireColumn.AutoFit
Columns("BT:CN").Select
Columns("BT:CN").EntireColumn.AutoFit
'hide banked and refunded columns on scheduled sheet
If Right(Range("A3").Value, 9) = "Scheduled" Then
Columns("CC:CN").Select
Selection.EntireColumn.Hidden = True
End If
'reset the height of title rows
Rows("2:2").Select
Selection.RowHeight = 21.75
Rows("3:3").Select
Selection.RowHeight = 36.75
Rows("5:5").Select
Selection.RowHeight = 36.75
'color code freq visits and closed
Application.Run "SetCloseColor"
Application.Run "SetDealerColor"
MsgBox "Complete"
Range("A6").Select
If c1 "" Then 'turn filter mode to on and filter by FS
Rows("5:5").Select
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:=c1
End If
'STATUS_________________________________________________________
Application.DisplayStatusBar = True
Application.StatusBar = "Updates complete"
c1 = ""
Application.DisplayStatusBar = False
End Sub
Sub Visits()
Dim rc As Variant, cc As Variant, acv As String, cur As Variant
'rc = row count, cc = column count, cur = current color
Range("BU5").Select
rc = 1
cc = 0
Do Until cc = 5
rc = 1
'Do Until rc = 601
Do Until rc = Int(Range("A4").Value + 1) 'a4 holds number of current records
acv = ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Value
cur = ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color
Select Case acv
Case Is > 0 'visit totals
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = 14
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Font.Bold = True
Case Else
ActiveCell.Offset(rowOffset:=rc, columnOffset:=cc).Interior.Color = cur
End Select
rc = rc + 1
Loop
cc = cc + 1
Loop
acv = ""
MsgBox "Complete"
End Sub
Hi,
So here's the story: I have 24 workbooks, with 12 sheets in each workbook. I have a macro written for EACH sheet in EACH workbook. I also have code written in the first module of EACH workbook. These 24 workbooks are in a folder.
I then have another workbook called "Export" which is not in the same folder as the workbooks. I have one macro in the module section of the "Export" workbook which accesses the folder with the 24 workbooks, copies the data from EACH sheet of EACH workbook and then pastes the data into "Export".
My problem is that each time the macro in "Export" opens each workbook it opens each macro in each workbook and it really slows things down (since EACH sheet of EACH workbook contains a macro + a macro in the module of EACH workbook). That's a lot of macros to open. Is there any way it doesn't have to open all these macros so the code can run faster?
Thanks for any help!!!
Hi all: I have the following section of code and i am trying to make it faster. Currently when this procedure runs the screen "changes" durings its execution. Now i know i can "turn off screen updating" and this will increase speed but are there commands in the code which will prevent the screen from updating. I know activating or selecting things causes the screen to change. Also, any inputs to make this faster/better would be greatly appreciated.
Code:
Sub compare_lists(droparray() As String, addarray() As String, userrange1 As Range, userrange2 As Range)
Dim Rng As Range
Dim x As Long
Dim cellitem As Range
Dim junk1 As String
Dim y As Integer
Dim junk2 As Boolean
x = 1
'Compares Current list of students to "new" downloaded list of students
For Each cellitem In userrange1
'This is the downloaded new list of students
With userrange2
Set Rng = .Find(What:=cellitem.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
'junk1 = Rng.Offset(0, 0).Value
Else
droparray(x) = cellitem
x = x + 1
End If
End With
Next cellitem
x = 1
'Compares New List of students to current list of students
For Each cellitem In userrange2
'This is the downloaded new list of students
With userrange1
Set Rng = .Find(What:=cellitem.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
'junk1 = Rng.Offset(0, 0).Value
Else
addarray(x) = cellitem
x = x + 1
End If
End With
Next cellitem
End Sub
Hi everyone, I'm new to this forum and I need some help. I have code that it pulling a query for my access database and copying the query results to a specified excel file. The code works fine but I would like to run faster. It is currently only copying eight fields. In the future this number will be around 150. Is there anything I can do to speed up this process? Thanks for any advice you can give.
Code:
Private Sub btnCumulativeSavings2_Click()
Dim csFileName, clientDir, ClientName, acctName As String
Dim ClientID, acctID As Integer
Dim sql As DAO.Recordset
Dim xlApp As Excel.Application
Dim csBook As Excel.Workbook
Dim vsheet As Excel.Worksheet
Dim SQLQuery As String
Dim clientRS As Recordset
Dim sqlattriblistid, sqlattribquant, sqlattribcost, sqlbillperid, sqlmobilecost, sqlaccountname, sqlshortname, sqlaccountparent, mobilerateid As DAO.Field
SQLQuery = "SELECT tblMobileDetail.MobileID, tblAttributeDetail.AttributeListID, tblAttributeDetail.AttributeQuantity, tblAttributeDetail.AttributeCost, tblMobileDetail.BillingPeriodID, tblMobileDetail.MobileRatePlanCost, tblAccounts.AccountName, tblOrg.ShortName, tblAccounts.AccountParentID, tblMobileDetail.MobileRatePlanID FROM tblOrg RIGHT JOIN (tblAccounts INNER JOIN (tblMobileNumber INNER JOIN (tblMobileDetail INNER JOIN tblAttributeDetail ON tblMobileDetail.MobileDetailID = tblAttributeDetail.MobileDetailID) ON tblMobileNumber.MobileNumberID = tblMobileDetail.MobileID) ON tblAccounts.AccountID = tblMobileNumber.AccountID) ON tblOrg.OrgID = tblAccounts.OwnerOrgID WHERE (((tblMobileDetail.BillingPeriodID)=39));"
Set sql = CurrentDb.OpenRecordset(SQLQuery, dbOpenDynaset)
sql.MoveLast
sql.MoveFirst
ClientID = cboClient
acctID = lstAcct
Set clientRS = CurrentDb.OpenRecordset("SELECT * FROM tblOrg WHERE OrgID = " & ClientID)
'SQLQuery = CurrentDb.QueryDefs("CumulativeSavings").Sql
clientRS.MoveLast
clientRS.MoveFirst
ClientName = clientRS!shortname
clientDir = getValueForKey("Dir.Root") & getValueForKey("Dir.Accounts.Active")
csFileName = "C:\Desktop\Test.Savings.xlsx"
Set xlApp = New Excel.Application
xlApp.Visible = True
Set csBook = xlApp.Workbooks.Open(csFileName, True, False)
Set vsheet = csBook.Sheets("VZW")
' GoTo Exit_Sub
' Else
' Exit Sub
' End If
Set sqlattriblistid = sql("AttributeListID")
Set sqlattribquant = sql("AttributeQuantity")
Set sqlattribcost = sql("AttributeCost")
Set sqlbillperid = sql("BillingPeriodID")
Set sqlmobilecost = sql("MobileRatePlanCOst")
Set sqlaccountname = sql("AccountName")
Set sqlshortname = sql("ShortName")
Set sqlaccountpart = sql("AccountParentID")
Set sqlmobilerateid = sql("MobileRatePlanID")
n = 0
sql.MoveFirst
Do Until sql.EOF
If n < 1000 Then
vsheet.Range("B8").Offset(n, 0).Value = sqlattriblistid.Value
vsheet.Range("C8").Offset(n, 0).Value = sqlattribquant.Value
vsheet.Range("D8").Offset(n, 0).Value = sqlattribcost.Value
vsheet.Range("E8").Offset(n, 0).Value = sqlbillperid.Value
vsheet.Range("F8").Offset(n, 0).Value = sqlmobilecost.Value
vsheet.Range("G8").Offset(n, 0).Value = sqlshortname.Value
vsheet.Range("H8").Offset(n, 0).Value = sqlaccountpart.Value
vsheet.Range("I8").Offset(n, 0).Value = sqlmobilerateid.Value
n = n + 1
End If
sql.MoveNext
Loop
sql.Close
Set clientRS = Nothing
Set csBook = Nothing
Set xlApp = Nothing
Set sql = Nothing
End Sub
I am only looping it through about 4 thousand records, looking for match and dups and moving it over to the other sheet, so why is my code running so slow?
I have run other programs where the records are in 40 thousand and it doesn't take as long as it is right now. Is there a way to make code run faster? thx
112x320 x6 worksheets have:
=IF(ISNA(VLOOKUP($A6,OFFSET([PVR.xls]Prices!$A$1,0,MATCH(DH$1,[PVR.xls]Prices!$A$1:$IA$1,0)-1,544,2),2,0)),INDEX(DH:DH,ROW()-1),VLOOKUP($A6,OFFSET([PVR.xls]Prices!$A$1,0,MATCH(DH$1,[PVR.xls]Prices!$A$1:$IA$1,0)-1,544,2),2,0))
Breakdown:
VLOOKUP($A6,OFFSET([test.xls]Prices!$A$1,0,MATCH(DH$1,[test.xls]Prices!$A$1:$IA$1,0)-1,544,2),2,0)) - match by Column A and by Row 1 from another table
-about 26 megs .xls file, any way of reducing the size/faster calculation of this? (112 columns by 320 rows)
Thank You!
Hello,
I'm working with a fairly large spreadsheet involving many calculations and was wondering if someone could give me some tips on designing worksheets to minimimize calculation times.
I'm using Excel 2007. I believe that in previous versions of Excel, calculation times were slower if calculations used data on cells from different worksheets. I also think that calculation times were lengthened by using 'IF' formulae rather than 'OFFSET'.
Could someone tell me if the old rules for improving calculation speeds in previous versions of Excel still apply to Excel 2007?
Also, I'd like help with the following specific cases:
-I need to run calculations using two grids of data. Each grid contains approximately 40,000 rows and 2,000 columns of data. Would the calculations using data from both of these grids be faster if they were on the same worksheet than if they were on separate worksheets?
-In general, is it faster to have calculations split up over multiple worksheets than entirely on one worksheet?
If anyone has a link they can send me that addresses these general questions it would be much appreciated!
Thanks in advance!
Derek
I have a spreadsheet with four connections to SQL stored procedures that create graphs on the same worksheet tab. It all works fine except for a messy detail. When I click the refresh all Icon, the screen jumps four times, once for each connection that gets refreshed. I would like to smooth that out, so I recorded a macro to refresh all, then inserted the "Application.Screenupdating..." lines based on some reading in the book store last night. (I'm very new to VBA.)
Sub Refresh()
'
' Refresh Macro
'
' Keyboard Shortcut: Ctrl+u
'
Application.ScreenUpdating = False
ActiveWorkbook.RefreshAll
Then Application.ScreenUpdating = True
End Sub
When I run this, the screen still jumps four times, so I guess I've done something wrong. Can anyone suggest a way to make this work - or an alternate approach!
Thanks!
|
|
