Problem: The 2nd loop of For j fails on the line of code where I "Test for which line accrual is on 66-71"
Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & ",11]").Text
This was working a few weeks ago but my IT and our SAP consultant advise nothing has changed..
Error: Run-time error '619'. The control could not be found by id
Attempts: I have tried a few error trappings, included in my code below, but nothing works.
I have done a lot of research but come up blank. I've also re-recorded the macro and nothing has changed.. I'm lost and looking for help!
edit
Alternate Reslution: How can I get all items/amounts/string on this ROW
session.FindById("wnd[0]/usr/lbl[11]").Text - row 11
end edit
Code:
Option Explicit
Sub SAP_TPM_Payment()
'Declare Variables
Dim wkb As Workbook
Dim wks_TPM As Worksheet
Dim LR_TPM_A As Long, LR_TPM_E As Long, LR_DeletedSku As Long, AccAmt As Long, LR_Copy As Long, LR_clearing As Long, PayEntries As Long, PayCount As Long
Dim Response As VbMsgBoxResult, Response2 As VbMsgBoxResult
Dim WSHshell, proc
Dim wkb2 As String, wkb2_fname As String
Dim wkb2_name As String
Dim dblStartTime As Double 'time elapsed counter
Dim strMinutesElapsed As String
Dim i As Long, j As Long, k, n As Long, o As Long, p As Long, c As Long
Dim Amt, Amt1, Amt2, Amt3, Amt4, Amt5, Amt6
Dim LR_TPM_J As Long, Line, AccRow
Dim Status, sku, SAP_Acc, SAP_Pay, ClearNo, SAP_Accrual, PayAmt, Customer
Dim Pcheck1, Pcheck2
Dim CustomerName
Dim SapGuiAuto
Dim SAPApp As GuiApplication
Dim SAPCon As GuiConnection
Dim session As GuiSession
'Set Variables
Set wkb = ThisWorkbook
Set wks_TPM = wkb.Sheets("TPM Payment")
'Timer
dblStartTime = Timer
'Speed up code
NeedForSpeed
'Start Code
If wks_TPM.Range("Q2") = "" Then
MsgBox "No claim no. - exiting sub"
Exit Sub
End If
wks_TPM.Range("H" & Cells(Rows.Count, "I").End(xlUp).Row + 1) = Application.UserName
wks_TPM.Range("H" & Cells(Rows.Count, "I").End(xlUp).Row + 2) = Date
'Gets unique Accruals from col 'A', copies to col 'E'
If wks_TPM.Range("A4") = "" Then
wks_TPM.Range("E3:F3").Value = wks_TPM.Range("A3:B3").Value
Else:
LR_TPM_A = wks_TPM.Range("A" & Rows.Count).End(xlUp).Row
wks_TPM.Range("A2:A" & LR_TPM_A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wks_TPM.Range("E2"), Unique:=True
End If
'Sums unique Accruals from col 'B', copies to col 'F'
LR_TPM_E = wks_TPM.Range("E" & Rows.Count).End(xlUp).Row
For i = 3 To LR_TPM_E
wks_TPM.Range("F" & i).Value = Application.SumIf(wks_TPM.Range("A:A"), wks_TPM.Range("E" & i), wks_TPM.Range("B:B"))
Next i
'Checks if SAP is open
On Error GoTo ErrRef
Response = MsgBox("Are you logged into SAP?" & vbCrLf & "" & vbCrLf & "Click 'Yes' if you are already logged into SAP" & vbCrLf & "Click 'No' to log into SAP" & vbCrLf & "Click 'Cancel' will exit the macro", vbYesNoCancel, "SAP Login Query")
If Response = vbNo Then
Set WSHshell = CreateObject("WScript.Shell")
Set proc = WSHshell.Exec("C:\Program Files (x86)\SAP\FrontEnd\SAPgui\saplogon.exe")
Response2 = MsgBox("Are you logged into SAP?" & vbCrLf & "" & vbCrLf & "Click 'Ok' once you have logged into SAP" & vbCrLf & "Click 'Cancel' will exit the macro", vbOKCancel, "SAP Login Query")
If Response2 = vbCancel Then
CreateObject("WScript.Shell").PopUp "Exiting macro...", 1, "SAP Login Query"
Exit Sub
End If
ElseIf Response = vbCancel Then
CreateObject("WScript.Shell").PopUp "Exiting macro...", 1, "SAP Login Query"
Exit Sub
End If
On Error GoTo 0
Set SapGuiAuto = GetObject("SAPGUI") 'Get the SAP GUI Scripting object
Set SAPApp = SapGuiAuto.GetScriptingEngine 'Get the currently running SAP GUI
Set SAPCon = SAPApp.Children(0) 'Get the first system that is currently connected
Set session = SAPCon.Children(0) 'Get the first session (window) on that connection
For j = 3 To LR_TPM_E
session.FindById("wnd[0]/tbar[0]/okcd").Text = "/n"
LR_TPM_J = wks_TPM.Range("J" & Rows.Count).End(xlUp).Row
SAP_Accrual = wks_TPM.Range("E" & j).Value
wks_TPM.Range("I" & LR_TPM_J + 1).Value = SAP_Accrual
session.FindById("wnd[0]").Maximize
session.FindById("wnd[0]/tbar[0]/okcd").Text = "/nVBO2"
session.FindById("wnd[0]").sendVKey 0
session.FindById("wnd[0]/usr/ctxtRV13A-KNUMA_BO").Text = SAP_Accrual
session.FindById("wnd[0]").sendVKey 0
'Confirms accrual is still active and not closed
Status = session.FindById("wnd[0]/usr/ctxtKONA-BOSTA").Text
If Status = "" Then
wks_TPM.Range("N" & LR_TPM_J + 1) = "Open"
Else
wks_TPM.Range("J" & LR_TPM_J + 1 & ":O" & LR_TPM_J + 1) = "Closed"
GoTo NextAccrual:
End If
'Confirms accrual is for the correct customer
Customer = session.FindById("wnd[0]/usr/txtKURGV-NAME1").Text
CustomerName = Split(Customer)(UBound(Split(Customer)))
If CustomerName = wks_TPM.Range("Q3") Then
wks_TPM.Range("Q4") = "Rebate Recipient matches claim"
Else
wks_TPM.Range("Q4") = "Rebate Recipient doesn't match claim"
GoTo NextAccrual:
End If
'Sales Volume (scrape accruals remaining)
session.FindById("wnd[0]").sendVKey 17
'Need to wait a second for SAP to catch up
Application.Wait (Now + TimeValue("00:00:01"))
Dim Cust As String
Cust = session.FindById("wnd[0]/usr/lbl[3,9]").Text
Dim CustPos As Long
CustPos = InStr(Cust, "a")
Debug.Print Cust
Debug.Print CustPos
''Test for which line amt is on
'Accrual sometimes on row 66-71, code for possibilities
Dim g
For g = 66 To 71
On Error GoTo Next_g:
Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & ",11]").Text
If IsEmpty(Amt) = False Then
If Amt <> "" Then
'Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & ",11]").Text
Debug.Print Amt & CStr(g)
'On Error GoTo 0
Exit For
End If
Else
Debug.Print CStr(g) & "nope"
End If
Next_g:
'On Error GoTo 0
Next g
' On Error Resume Next
' Amt1 = session.FindById("wnd[0]/usr/lbl[66,11]").Text
' If Err.Number <> 0 Then
' Err.Clear
' End If
' Amt2 = session.FindById("wnd[0]/usr/lbl[67,11]").Text
' Amt3 = session.FindById("wnd[0]/usr/lbl[68,11]").Text
' Amt4 = session.FindById("wnd[0]/usr/lbl[69,11]").Text
' Amt5 = session.FindById("wnd[0]/usr/lbl[70,11]").Text
' Amt6 = session.FindById("wnd[0]/usr/lbl[71,11]").Text
' On Error GoTo 0
'' 'Accrual sometimes on row 66-71, code for possibilities
'' On Error GoTo Handler1:
'' Amt1 = session.FindById("wnd[0]/usr/lbl[66,11]").Text
''Waypoint1:
'' On Error GoTo Handler2:
'' Amt2 = session.FindById("wnd[0]/usr/lbl[67,11]").Text
''Waypoint2:
'' On Error GoTo Handler3:
'' Amt3 = session.FindById("wnd[0]/usr/lbl[68,11]").Text
''Waypoint3:
'' On Error GoTo Handler4:
'' Amt4 = session.FindById("wnd[0]/usr/lbl[69,11]").Text
''Waypoint4:
'' On Error GoTo Handler5:
'' Amt5 = session.FindById("wnd[0]/usr/lbl[70,11]").Text
''Waypoint5:
'' On Error GoTo Handler6:
'' Amt6 = session.FindById("wnd[0]/usr/lbl[71,11]").Text
'' On Error GoTo 0
'AccAmt used for payment
AccAmt = LR_TPM_J + 1
''''''''''
'Amt Code'
''''''''''
'If IsEmpty(Amt) = False And Amt <> "" Then
Line = LR_TPM_J + 1
AccRow = -1
ReRun:
'********************
Dim ScrollBarPosOrig As Long, ScrollBarPosNew As Long, ScrollBarPosUpdate As Long
ScrollBarPosOrig = session.FindById("wnd[0]/usr").VerticalScrollbar.Position
session.FindById("wnd[0]/usr").VerticalScrollbar.Position = 2
ScrollBarPosUpdate = session.FindById("wnd[0]/usr").VerticalScrollbar.Position
If ScrollBarPosUpdate = ScrollBarPosOrig Then
GoTo ScrollBarNone:
Else
GoTo ScrollBar:
End If
ScrollBarNone:
For k = 10 To 100 Step 2 '1024 to act like infinity
sku = session.FindById("wnd[0]/usr/lbl[3," & CStr(k) & "]").Text
If sku = "" Then
MsgBox "Exit For"
End If
wks_TPM.Range("J" & Line) = Split(sku)(UBound(Split(sku))) 'gets last numbr from string, which is the sku/material
wks_TPM.Range("I" & Line) = SAP_Accrual
Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & "," & CStr(k + 1) & "]").Text
If Right(Amt, 1) = "-" Then 'Converts to number
wks_TPM.Range("K" & Line).Value = Left(Amt, Len(Amt) - 1)
Else: wks_TPM.Range("K" & Line).Value = "0" 'Zero $$ is the amount is a debit (overpaid accrual)
End If
Line = Line + 1
AccRow = AccRow + 1
Next k
ScrollBar:
session.FindById("wnd[0]/usr").VerticalScrollbar.Position = 0
ScrollBarPosOrig = session.FindById("wnd[0]/usr").VerticalScrollbar.Position
For k = 2 To 1000 Step 2 '1024 to act like infinity
sku = session.FindById("wnd[0]/usr/lbl[3,10]").Text
If sku = "" Then
MsgBox "Exit For"
End If
wks_TPM.Range("J" & Line) = Split(sku)(UBound(Split(sku))) 'gets last numbr from string, which is the sku/material
wks_TPM.Range("I" & Line) = SAP_Accrual
Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & ",11]").Text
If Right(Amt, 1) = "-" Then 'Converts to number
wks_TPM.Range("K" & Line).Value = Left(Amt, Len(Amt) - 1)
Else: wks_TPM.Range("K" & Line).Value = "0" 'Zero $$ is the amount is a debit (overpaid accrual)
End If
Line = Line + 1
AccRow = AccRow + 1
On Error Resume Next
SAP_Acc = session.FindById("wnd[0]/usr/lbl[3,13]").Text
Debug.Print Split(SAP_Acc)(UBound(Split(SAP_Acc)))
On Error GoTo 0
Debug.Print SAP_Accrual 'testing
If Split(SAP_Acc)(UBound(Split(SAP_Acc))) = CStr(SAP_Accrual) Then
GoTo EndOfAccrual:
End If
session.FindById("wnd[0]/usr").VerticalScrollbar.Position = k
Next k
EndOfAccrual:
On Error GoTo 0
'Copy delete sku formula
wks_TPM.Range("O2").Copy
wks_TPM.Range("O" & LR_TPM_J + 1 & ":O" & Cells(Rows.Count, "I").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormulas
'Only calculates changed/updated cells
Application.Calculate
'Format cells
wks_TPM.Range("O3:O" & Cells(Rows.Count, "I").End(xlUp).Row).HorizontalAlignment = xlCenter
'If any sku is "marked for deletion", change amount to 0
LR_DeletedSku = wks_TPM.Range("O" & Rows.Count).End(xlUp).Row
For n = LR_TPM_J + 1 To LR_DeletedSku
If wks_TPM.Range("O" & n) = "X" Then
wks_TPM.Range("K" & n) = "0"
End If
Next n
'Copy amount to be paid formula
wks_TPM.Range("M2").Copy
wks_TPM.Range("M" & LR_TPM_J + 1 & ":M" & Cells(Rows.Count, "J").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormulas
'Only calculates changed/updated cells
Application.Calculate
'Format cells
wks_TPM.Range("M3:M" & Cells(Rows.Count, "J").End(xlUp).Row).NumberFormat = "#,##0.00_)"
wks_TPM.Range("M3:M" & Cells(Rows.Count, "J").End(xlUp).Row).HorizontalAlignment = xlRight
'Go back one screen (equivalent of "F3")
session.FindById("wnd[0]").sendVKey 3
'Payment of Accrual
PayAmt = wks_TPM.Range("M" & AccAmt).Value
PayEntries = Line - AccAmt
If PayAmt <> "No" Then 'Pay Claim
session.FindById("wnd[0]").sendVKey 24 'Pay (equivalent of "Shift+F12")
'Test if there is a scrollbar
ScrollBarPosOrig = session.FindById("wnd[0]/usr").VerticalScrollbar.Position
ScrollBarPosNew = ScrollBarPosOrig + (o + 1)
ScrollBarPosUpdate = session.FindById("wnd[0]/usr").VerticalScrollbar.Position
If ScrollBarPosUpdate = ScrollBarPosOrig Then
GoTo ScrollBarNonePay:
Else
GoTo ScrollBarPay:
End If
ScrollBarNonePay:
For o = 0 To PayEntries
PayAmt = wks_TPM.Range("M" & AccAmt).Value
session.FindById("wnd[0]/usr/sub:SAPMV13A:3007/txtKONPD-BZWRT[" & CStr(o) & ",48]").Text = PayAmt
session.FindById("wnd[0]").sendVKey 0
AccAmt = AccAmt + 1
PayEntries = PayEntries - 1
If PayEntries = 0 Then
GoTo SavePayment:
End If
Next o
ScrollBarPay:
For o = 0 To PayEntries
PayAmt = wks_TPM.Range("M" & AccAmt).Value
session.FindById("wnd[0]/usr/sub:SAPMV13A:3007/txtKONPD-BZWRT[0,48]").Text = PayAmt
session.FindById("wnd[0]").sendVKey 0
AccAmt = AccAmt + 1
PayEntries = PayEntries - 1
If PayEntries = 0 Then
GoTo SavePayment:
End If
session.FindById("wnd[0]/usr").VerticalScrollbar.Position = (o + 1)
Next o
Else: GoTo NextAccrual:
End If
SavePayment:
'Need to wait a second for SAP to catch up
Application.Wait (Now + TimeValue("00:00:01"))
'Saves payment
session.FindById("wnd[0]").sendVKey 11
session.FindById("wnd[0]").sendVKey 0
'Need to wait a second for SAP to catch up
Application.Wait (Now + TimeValue("00:00:02"))
'Press "Enter" to go back into agreement
session.FindById("wnd[0]").sendVKey 0
'Selects rebate paymnts -> rebate docs
session.FindById("wnd[0]/mbar/menu[3]/menu[3]").Select
'Selects partial settelment
session.FindById("wnd[1]").sendVKey 0
'Selects first line
session.FindById("wnd[2]/usr/cntlCUSTOM_CONTAINER/shellcont/shell").SelectItem "000000000001", "COL0"
session.FindById("wnd[2]/usr/cntlCUSTOM_CONTAINER/shellcont/shell").ClickLink "000000000001", "COL0"
'Need to wait a second for SAP to catch up
Application.Wait (Now + TimeValue("00:00:02"))
'Selects Sales Doc -> Change
session.FindById("wnd[0]/mbar/menu[0]/menu[1]").Select
'Need to wait a couple of seconds for SAP to save - needs 2 secs, tried 1 sec but fails
Application.Wait (Now + TimeValue("00:00:02"))
'Updated date to today
session.FindById("wnd[0]/usr/tabsTAXI_TABSTRIP_OVERVIEW/tabpT\02/ssubSUBSCREEN_BODY:SAPMV45A:4415/ctxtVBKD-FKDAT").Text = Format(Date, "dd.mm.yyyy")
'Claim no.
session.FindById("wnd[0]/usr/subSUBSCREEN_HEADER:SAPMV45A:4021/txtVBKD-BSTKD").Text = wks_TPM.Range("Q2")
session.FindById("wnd[0]").sendVKey 0
'Selects Sales Document -> Billing -> Save
session.FindById("wnd[0]/mbar/menu[0]/menu[8]").Select
'Get Clearing Doc no.
ClearNo = session.FindById("wnd[0]/sbar").Text
If Split(ClearNo, Chr$(32))(1) Like "*6*" Then
wks_TPM.Range("L" & AccAmt - 1) = Split(ClearNo, Chr$(32))(1)
End If
'Enter thru "warning"
session.FindById("wnd[0]").sendVKey 0
'Need to wait a second for SAP to catch up
Application.Wait (Now + TimeValue("00:00:02"))
'Get Clearing Doc no. take 2 as enter thru errors producs different status bar text
ClearNo = session.FindById("wnd[0]/sbar").Text
If wks_TPM.Range("L" & AccAmt - 1) = "" Then
If Split(ClearNo, Chr$(32))(1) Like "*6*" Then
wks_TPM.Range("L" & AccAmt - 1) = Split(ClearNo, Chr$(32))(1)
End If
End If
session.FindById("wnd[0]").sendVKey 11
'Need to wait a second for SAP to catch up
Application.Wait (Now + TimeValue("00:00:02"))
NextAccrual:
Next j
'Copy clearing doc no.
For c = 3 To LR_TPM_A
wks_TPM.Range("C" & c).Value = Application.SumIf(wks_TPM.Range("I:I"), wks_TPM.Range("A" & c), wks_TPM.Range("L:L"))
Next c
Dim pathTPM_temp As String
Dim fnameTPM_temp As String
'Enter VB05N trans to get payment details
session.FindById("wnd[0]/tbar[0]/okcd").Text = "/nVA05N"
session.FindById("wnd[0]").sendVKey 0
session.FindById("wnd[0]/usr/ctxtSKUNNR-LOW").Text = ""
session.FindById("wnd[0]/usr/txtPBSTKD").Text = wks_TPM.Range("Q2")
session.FindById("wnd[0]").sendVKey 8
'Export to 'local file'
session.FindById("wnd[0]").sendVKey 45
session.FindById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").Select
session.FindById("wnd[1]/tbar[0]/btn[0]").Press
pathTPM_temp = "C:\Users\adamsmit\Desktop\"
session.FindById("wnd[1]/usr/ctxtDY_PATH").Text = pathTPM_temp
fnameTPM_temp = "export.xls"
session.FindById("wnd[1]/usr/ctxtDY_FILENAME").Text = fnameTPM_temp
session.FindById("wnd[1]").sendVKey 11
'Need to wait a couple of seconds for SAP to save - needs 2 secs, tried 1 sec but fails
Application.Wait (Now + TimeValue("00:00:01"))
Dim wkbTPM_temp As Workbook
Dim wksTPM_temp As Worksheet
'Open "export" file and filter for current payments
Set wkbTPM_temp = Workbooks.Open(FileName:=pathTPM_temp & fnameTPM_temp)
Set wksTPM_temp = Workbooks("export.xls").Worksheets("export")
'Format file
With wksTPM_temp
.Rows("5:5").EntireRow.Delete
.Rows("1:3").EntireRow.Delete
.Columns("A:A").EntireColumn.Delete
.AutoFilterMode = False
With .Range("A1:O1")
.AutoFilter
.AutoFilter Field:=2, Criteria1:=Environ("UserName")
.AutoFilter Field:=4, Criteria1:=Format(Date, "dd.mm.yyyy")
End With
End With
Debug.Print pathTPM_temp & fnameTPM_temp
With wkbTPM_temp
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "copy"
End With
Dim wksTPM_copy As Worksheet
Dim LR_hidden As Long
Set wksTPM_copy = Workbooks("export.xls").Worksheets("copy")
wksTPM_temp.Range("A1:" & wksTPM_temp.Range("K1").End(xlDown).Address).Copy wksTPM_copy.Range("A1")
'Get LR for copy to claims file below
LR_Copy = wksTPM_copy.Range("A" & Rows.Count).End(xlUp).Row
'Find Open Claims file to paste data into
Dim wbcount2 As Long
wbcount2 = Workbooks.Count
For i = 1 To wbcount2
If Workbooks(i).Path & "\" & Workbooks(i).Name Like "*" & wks_TPM.Range("Q2") & "*" Then
wkb2 = Workbooks(i).Path & "\" & Workbooks(i).Name
wkb2_fname = Workbooks(i).Path & "\" & Workbooks(i).Name
wkb2_name = Workbooks(i).Name
Debug.Print wkb2_name
Exit For
End If
Next i
Dim wkbClaim As Workbook
Dim wksClaim_clearing As Worksheet
Set wksClaim_clearing = Workbooks(wkb2_name).Worksheets("Clearing")
LR_clearing = wksClaim_clearing.Range("A" & Rows.Count).End(xlUp).Row
wksTPM_copy.Range("A2:K" & LR_Copy).Copy wksClaim_clearing.Range("A" & LR_clearing + 1)
'Kill temp "export" workbook
wkbTPM_temp.Close SaveChanges:=False
strMinutesElapsed = Format((Timer - dblStartTime) / 86400, "hh:mm:ss") 'stops timer - Determine how many seconds code took to run
MsgBox "This code ran successfully in " & strMinutesElapsed, vbInformation 'Msg box for elapsed time & Claims consldaited
ResetSpeed
Exit Sub
ErrRef: MsgBox ("Liar!!!" & vbCrLf & "" & vbCrLf & "Adam - 1" & vbCrLf & "You - 0")
ResetSpeed
Exit Sub
''Handler1: 'jump done, error handling is now disabled
'' Resume Waypoint1
''Handler2: 'jump done, error handling is now disabled
'' Resume Waypoint2
''Handler3: 'jump done, error handling is now disabled
'' Resume Waypoint3
''Handler4: 'jump done, error handling is now disabled
'' Resume Waypoint4
''Handler5: 'jump done, error handling is now disabled
'' Resume Waypoint5
''Handler6: 'jump done, error handling is now disabled
'' Resume Next
End Sub
How does your program behave when you make these changes?
...
Dim g
For g = 66 To 71
On Error Resume Next
Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & ",11]").Text
If err.number = 0 Then
On Error Goto 0
If Amt <> "" Then
'Amt = session.FindById("wnd[0]/usr/lbl[" & CStr(g) & ",11]").Text
Debug.Print Amt & CStr(g)
Exit For
End If
Else
On Error Goto 0
Debug.Print CStr(g) & "nope"
End If
Next g
...
Regards, ScriptMan
I would make the following change first:
...
Next_g:
'On Error GoTo 0
Next g
On Error Goto 0
...
Then you can see where is the actual error.
Regards, ScriptMan
Related
I am having an issue getting a variable set to pass to a function properly. The frustrating part is that until yesterday this code has been working properly for a good 4 months of weekly use.
Below is the code, removing the dims and parts of the code that will not help resolve this issue.
Sub Combined_15_and_45()
'Dim Iteration Variables
'Dim tracking variables
'Dim range variables
'Dim Invoice Value Variables
'Dim Email body variables
Set wb = ThisWorkbook
Set WithTerms = Sheet4
Set APEmail = Sheet7
With wb
With WithTerms
lrow = .Cells(Rows.Count, 5).End(xlUp).Row
elrow = Sheet7.Cells(Rows.Count, 1).End(xlUp).Row
CalcDate = .Cells(1, 3).Value
i = 1
'loop through looking for times when cell above is different *Store i Instance
'loop through looking for times when cell below is different *Store i as EndInstance
'Specifically searching for changes in account number
For i = 4 To lrow
h = i - 1
j = i + 1
Set rng = .Cells(i, 5)
Set RngUp = .Cells(h, 5)
Set RngDwn = .Cells(j, 5)
'this is where vendor account changes.
If rng.Value <> RngUp.Value Then
instance = i
End If
'Check if invoice for the line is extreme past due *Store i as MaxOvrDue
If .Cells(i, 10).Value <= .Range("C1").Value - 45 Then
MaxOvrDue = i
End If
'check if invoice for line is +15 day overdue, less than 45 * Store i as MidOvrDur
If .Cells(i, 10).Value <= .Range("C1").Value - 15 Then
If .Cells(i, 10).Value >= .Range("C1").Value - 44 Then
If MidOvrdue = 0 Then
MidOvrdue = i
End If
End If
End If
'Check if Invoice for line is 15+ days overdue (Minimum) *Store i as Ovrdue
If .Cells(i, 10).Value < .Range("C1").Value Then
If .Cells(i, 10).Value <= .Range("C1").Value - 14 Then
OvrDue = i
End If
End If
'figure values for the totals of each section
If rng.Value <> RngDwn.Value Then
EndInstance = i
TotalOverdue = Application.WorksheetFunction.SumIfs(.Range("K:K"), .Range("E:E"), .Cells(instance, 5), .Range("J:J"), "<" & (.Range("c1") - 15))
XtrmOverdue = Application.WorksheetFunction.SumIfs(.Range("K:K"), .Range("E:E"), .Cells(instance, 5), .Range("J:J"), "<" & .Range("C1") - 44)
MidTotalOverdue = Application.WorksheetFunction.SumIfs(.Range("K:K"), .Range("E:E"), .Cells(instance, 5), .Range("J:J"), "<" & .Range("C1") - 15, .Range("J:J"), ">=" & .Range("C1") - 45)
If OvrDue = 0 And MaxOvrDue = 0 And MidOvrdue = 0 Then
Else:
'begin building Extremely Overdue Invoice Text
If MaxOvrDue <> 0 And MidOvrdue = 0 Then
**Set XtrmTblRng = .Range(.Cells(instance, 7), .Cells(MaxOvrDue, 11))**
End If
If OvrDue <> 0 And MidOvrdue <> 0 Then
If MaxOvrDue = 0 And OvrDue <= MidOvrdue Then
**Set MidTblRng = .Range(.Cells(MidOvrdue, 7), .Cells(OvrDue, 11))**
'Begin building ONLY overdue email text
Else:
'begin building segments to add to extreme overdue email
**Set XtrmComboTblRng = .Range(.Cells(instance, 7), .Cells(OvrDue, 11))**
End If
End If
If OvrDue <> 0 Then
'Generate the email
With OutMail
.To = eAddy
'Figure out which email to send
If MaxOvrDue <> 0 And MidTotalOverdue <> 0 Then
.HTMLbody = StrBodyXtrm & RangetoHTML(XtrmComboTblRng, CalcDate) & ComboStrBody2 & StrBody4
Else
If MaxOvrDue <> 0 And MidOvrdue = 0 Then
.HTMLbody = StrBodyXtrm & RangetoHTML(XtrmTblRng, CalcDate) & StrBody2 & StrBody4
Else:
.HTMLbody = StrBodyOverdue & RangetoHTML(MidTblRng, CalcDate) & StrBody3
End If
End If
.display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End If
'clear variables when changing vendor IDs
End If
Set rng = .Cells(j, 5)
Next i
End With
End With
End Sub
Function RangetoHTML(TblRng, CalcDate)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim tRow As Long
Dim i As Long
Dim CalcDate2 As Double
Dim TempDate As Double
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste the data in. This is where I am getting errors all the sudden
**TblRng.Copy**
'manipulate the data from table to fit needs and past into email.
End Function
Essentially this is trying to sort through stack of invoices and determine which email format to use.
Invoices aged 45+
Invoices aged 15-45+
Invoices aged 15-44
I am running into an issue with the email determining a different email format should be used than the TblRng variable that has been built to pass to the function. I just cant seem to find my logic error.
I have been banging my head against a wall for a few days now trying to fix this with no luck. Any help you can give will make you a hero in my eyes!
Thank you
The problem with your logic is with this line
If maxOvrDue = 0 And OvrDue <= midOvrDue Then
If there are no >45 lines (maxOvrDue = 0) then at the first occurance of a >15 line
midOvrDue and OvrDue will be the same. On subsequent >15 lines OvrDue will
be greater than midOvrDue. So the above will be true for 1 and false for 2 or more
lines in the 44-15 range. With 2 or more the default Else option will then Set XtrmComboTblRng not MidTblRng.
Later because maxOvrDue = 0 the email .HTMLbody uses RangetoHTML(MidTblRng, CalcDate).
The remedy would be to just use If maxOvrDue = 0 Then.
You could set an email type within the same logic as used to set the ranges so the mismatch can't occur. Here is an example of how to do that
Option Explicit
Sub Combined_15_and_45()
Dim WithTerms As Worksheet, APEMail As Worksheet
Dim rng As Range, tblRng As Range
Dim lrow As Long, elrow As Long, i As Long
Dim instance As Long, maxOvrDue As Long, midOvrDue As Long
Dim CalcDate As Date, DaysLate As Integer, EmailFormat As Integer
Dim has45 As Boolean, has15 As Boolean
Dim acc As String
Dim TotalOverdue As Currency
Dim XtrmOverdue As Currency, MidTotalOverdue As Currency
Set APEMail = Sheet7
elrow = APEMail.Cells(Rows.Count, 1).End(xlUp).row
' for debugging
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
' scan down sheet
Set WithTerms = Sheet4
With WithTerms
lrow = .Cells(Rows.Count, "E").End(xlUp).row 'Row E
CalcDate = .Range("C1").Value
For i = 4 To lrow
'this is where vendor account changes.
Set rng = .Cells(i, 5) ' E Account
If rng.Value <> rng.Offset(-1).Value Then
acc = rng
instance = i
maxOvrDue = 0
midOvrDue = 0
XtrmOverdue = 0
MidTotalOverdue = 0
End If
' check days overdue
DaysLate = DateDiff("d", .Cells(i, "J").Value, CalcDate)
If DaysLate >= 45 Then
maxOvrDue = i
XtrmOverdue = XtrmOverdue + .Cells(i, "K")
ElseIf DaysLate >= 15 Then
midOvrDue = i
MidTotalOverdue = MidTotalOverdue + .Cells(i, "K")
End If
' is this last for account
If rng <> rng.Offset(1) Then
TotalOverdue = XtrmOverdue + MidTotalOverdue
Debug.Print vbCr & acc & " Total", XtrmOverdue, MidTotalOverdue, TotalOverdue
has45 = maxOvrDue > 0
has15 = midOvrDue > 0
If has45 Or has15 Then
If has45 And has15 Then
EmailFormat = 1
Set tblRng = .Range(.Cells(instance, 7), .Cells(midOvrDue, 11))
Debug.Print "+45 and +15", tblRng.Address
' begin building segments to add to extreme overdue email
ElseIf has45 Then
EmailFormat = 2
Set tblRng = .Range(.Cells(instance, 7), .Cells(maxOvrDue, 11))
Debug.Print "+45 only", tblRng.Address
' begin building Extremely Overdue Invoice Text
ElseIf has15 Then
EmailFormat = 3
Set tblRng = .Range(.Cells(instance, 7), .Cells(midOvrDue, 11))
Debug.Print "+15 only", tblRng.Address
' begin building ONLY overdue email text
End If
' select email format
Dim body As String
Select Case EmailFormat
Case 1
body = "strBodyXtrm" & RangetoHTML(tblRng, CalcDate) & "ComboStrBody2 & strBody4"
Case 2
body = "strBodyXtrm" & RangetoHTML(tblRng, CalcDate) & "strBody2 & strBody4"
Case 3
body = "strBodyOverdue" & RangetoHTML(tblRng, CalcDate) & "strBody3"
End Select
' create html file for checking
Set ts = fso.createTextFile(ThisWorkbook.Path & "\" & acc & ".html", 1)
ts.write body
ts.Close
'Generate the email
'With outmail
'.To = eAddy
'.HTMLbody = body
'.display
'End with
End If
End If
Next i
End With
MsgBox "Done"
End Sub
Function RangetoHTML(tblRng, CalcDate) As String
Dim s, rw As Range, cell As Range, pre As String
pre = "<pre>TblRng=" & tblRng.Address(External:=1) & "</pre>"
s = "<tr align=""center"" bgcolor=""#ddddff"">" & _
"<th>Col G</th><th>Col H</th><th>Col I</th>" & _
"<th>Col J</th><th>Col K</th></tr>" & vbCrLf
For Each rw In tblRng.Rows
s = s & "<tr>"
For Each cell In rw.Cells
s = s & "<td>" & cell & "</td>"
Next
s = s & "</tr>" & vbCrLf
Next
RangetoHTML = pre & "<table cellspacing=""0"" cellpadding=""3"" border=""1"">" & _
s & "</table>" & vbCrLf
End Function
I want to compare 2 excels files [Having only 1 sheet in both] having 10-15 columns and rows will be more than 30K. We got one excel macro file which complete the comparison within 5-10Mins. Limitation of this macro is that it can compare only 2-3 columns at a time. So every time we need to run this macro multiple times which is time consuming process. So I created one utility file [.vbs file] which perform this task in one go but it takes around 1-3Hrs.
Is there any other way to perform this comparison in short time in one go?
startTime=Timer()
Set objExcel=Createobject("Excel.application")
objExcel.Visible=True
Set objWorkbook=objExcel.Workbooks.Open("E:\QTP trial version\Data.xls")
'Set deleteAnalysis_CopySheet=objWorkbook.sheets("Analysis_Copy")
'deleteAnalysis_CopySheet.delete
'Set deleteSummarySheet=objWorkbook.sheets("Summary")
'deleteSummarySheet.delete
Set objAnalysis_Copy=objWorkbook.sheets.add
objAnalysis_Copy.name="Analysis_Copy"
Set objSummary=objWorkbook.sheets.add
objSummary.name="Summary"
objSummary.Cells(1,1)="Analysis Row Count"
objSummary.Cells(2,1)="Reporting Row Count"
objSummary.Cells(3,1)="Analysis Column Count"
objSummary.Cells(4,1)="Reporting Column Count"
objSummary.Cells(5,1)="Difference of Row Count"
objSummary.Cells(6,1)="Difference of Column Count"
objSummary.Cells(7,1)="False Count"
' ------------------------1st Check - Verify the position of ''Metrics' in Analysis and Reporting tab. It must be same---------------------
'Get the control of Analysis tab
Set objAnalysis=objExcel.Worksheets.Item("Analysis")
intAnalysisRowCount=objAnalysis.Usedrange.rows.count
objSummary.Cells(1,2)=intAnalysisRowCount
intAnalysisColCount=objAnalysis.Usedrange.Columns.count
objSummary.Cells(3,2)=intAnalysisColCount
'Get Column number of 'Metric' Column from Analysis tab
For intMetricAnalysis=1 to intAnalysisColCount
If(Trim(Lcase(objAnalysis.Cells(1,intMetricAnalysis)))=Trim(Lcase("Metrics"))) Then
Exit for
End If
Next
'Get all Analysis columns in 1 string
strAnalysisColumnOrder=""
For intAnalysisColumnOrder=1 to intAnalysisColCount
strAnalysisColumnOrder=strAnalysisColumnOrder&"*"&objAnalysis.Cells(1,intAnalysisColumnOrder)
If(intAnalysisColumnOrder=1) then
strAnalysisColumnOrder=Replace(strAnalysisColumnOrder,"*","")
End If
Next
Set objReporting=objExcel.Worksheets.Item("Reporting")
intReportingRowCount=objReporting.Usedrange.rows.count
objSummary.Cells(2,2)=intReportingRowCount
intReportingColCount=objReporting.Usedrange.Columns.count
objSummary.Cells(4,2)=intReportingColCount
''Get Column number of 'Metric' Column from Reporting tab
For intMetricReporting=1 to intReportingColCount
If(Trim(Lcase(objReporting.Cells(1,intMetricReporting)))=Trim(Lcase("Metrics"))) Then
Exit for
End If
Next
'Get all Reporting columns in 1 string
strReportingColumnOrder=""
For intReportingColumnOrder=1 to intAnalysisColCount
strReportingColumnOrder=strReportingColumnOrder&"*"&objReporting.Cells(1,intReportingColumnOrder)
If(intReportingColumnOrder=1) then
strReportingColumnOrder=Replace(strReportingColumnOrder,"*","")
End If
Next
''Metric' column number must be same
If(intMetricAnalysis<>intMetricReporting) then
msgbox "Merics column is at "&intMetricAnalysis&" position in 'Analysis' Tab And at "&intMetricReporting&" position in 'Reporting' tab. 'Metrics' column should be at same position in both tab."
strMetricsFlag=False
Else
strMetricsFlag=True
End IF
'-----------2nd Check, Verify count of columns in 'Analysis' And 'Reporting' tab . It Must be same
If intAnalysisColCount<>intReportingColCount Then
msgbox "Column count of 'Reporting' Tab is not same as of 'Analysis tab'."
strAnalysisColCount=False
Else
strAnalysisColCount=True
End If
''---------------3rd Check , Verify Order of columns in 'Analysis' And 'Reporting' tab . It Must be same
If Trim(Lcase(strAnalysisColumnOrder))<>Trim(Lcase(strReportingColumnOrder)) then
msgbox "Column order of 'Reporting' Tab is not same as of 'Analysis tab'. Reporting column order should be "&strAnalysisColumnOrder
strAnalysisColumnOrderFlag=False
Else
strAnalysisColumnOrderFlag=True
End IF
'Creare 'Analysis_Copy' tab and add headers
Set objAnalysisCopy=objExcel.Worksheets.Item("Analysis_Copy")
strFirstCoulmn_AggKeys=""
For intHeaderAggkey=1 to intMetricAnalysis-1
strFirstCoulmn_AggKeys=strFirstCoulmn_AggKeys&"*"&objAnalysis.Cells(1,intHeaderAggkey)
If(intHeaderAggkey=1) then
strFirstCoulmn_AggKeys=Replace(strFirstCoulmn_AggKeys,"*","")
End If
Next
objAnalysisCopy.Cells(1,1)=strFirstCoulmn_AggKeys
strSecondCoulmn_AnalysisMetrics=""
For intHeaderAnalysisMetrics=intMetricAnalysis+1 to intAnalysisColCount
strSecondCoulmn_AnalysisMetrics=strSecondCoulmn_AnalysisMetrics&"*"&objAnalysis.Cells(1,intHeaderAnalysisMetrics)
If(intHeaderAnalysisMetrics=intMetricAnalysis+1 ) then
strSecondCoulmn_AnalysisMetrics=Replace(strSecondCoulmn_AnalysisMetrics,"*","")
End If
Next
objAnalysisCopy.Cells(1,2)="Analysis_"&strSecondCoulmn_AnalysisMetrics
objAnalysisCopy.Cells(1,3)="Reporting_"&strSecondCoulmn_AnalysisMetrics
objAnalysisCopy.Cells(1,4)="Status"
objWorkbook.Save
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
If strAnalysisColumnOrderFlag=False OR strMetricsFlag=False OR strAnalysisColCount=False Then
msgbox "So Data Comparision can not be done"
objWorkbook.Save
objWorkbook.Close
objExcel.Quit
Else
intFalseCount=0
For intAnalysisRow=2 to intAnalysisRowCount
' ------ Get the control of ''Analysis' tab and the string of Aggrecate Keys [strAnalysisAggrData] and respective metrics [strAnalysisMetricsData]
Set objAnalysis=objExcel.Worksheets.Item("Analysis")
' Append all data of each row which is before 'Metrics' column
strAnalysisAggrData=""
For intAnalysisColumn=1 to intMetricAnalysis-1
strAnalysisAggrData=strAnalysisAggrData&"*"&objAnalysis.Cells(intAnalysisRow,intAnalysisColumn)
If(intAnalysisColumn=1) then
strAnalysisAggrData=Replace(strAnalysisAggrData,"*","")
End If
Next
' ' Append all data of each row which is after 'Metrics' column
strAnalysisMetricsData=""
For intFromMetric=intMetricAnalysis+1 to intAnalysisColCount
strAnalysisMetricsData=strAnalysisMetricsData&"*"&objAnalysis.Cells(intAnalysisRow,intFromMetric)
If(intFromMetric=intMetricAnalysis+1 ) then
strAnalysisMetricsData=Replace(strAnalysisMetricsData,"*","")
End If
Next
' ------ Get the control of ''Reporting' tab and the string of Aggrecate Keys [strAnalysisAggrData] and respective metrics [strAnalysisMetricsData]
Set objReporting=objExcel.Worksheets.Item("Reporting")
For intReportingRow=1 to intReportingRowCount
' Append all data of each row which is before 'Metrics' column
strReportingAggrData=""
For intBeforeMetricReporting=1 to intMetricReporting-1
strReportingAggrData=strReportingAggrData&"*"&objReporting.Cells(intReportingRow,intBeforeMetricReporting)
If(intBeforeMetricReporting=1) then
strReportingAggrData=Replace(strReportingAggrData,"*","")
End If
Next
' Append all data of each row which is after 'Metrics' column
strReportingMetricsData=""
For intFromReportingMetric=intMetricReporting+1 to intReportingColCount
strReportingMetricsData=strReportingMetricsData&"*"&objReporting.Cells(intReportingRow,intFromReportingMetric)
If(intFromReportingMetric=intMetricReporting+1 ) then
strReportingMetricsData=Replace(strReportingMetricsData,"*","")
End If
Next
'------------------------------------------------------------ Actual Comparision will be from here ------------------------------------------
If Trim(LCase(strAnalysisAggrData))=Trim(LCase(strReportingAggrData)) Then
objAnalysisCopy.Cells(intAnalysisRow,1)=strAnalysisAggrData
objAnalysisCopy.Cells(intAnalysisRow,2)=strAnalysisMetricsData
objAnalysisCopy.Cells(intAnalysisRow,3)=strReportingMetricsData
'Compare Metrics Data
If Trim(LCase(strAnalysisMetricsData))=Trim(LCase(strReportingMetricsData)) Then
objAnalysisCopy.Cells(intAnalysisRow,4)="PASS"
objAnalysisCopy.Cells(intAnalysisRow,4).font.color=vbGreen
Else
objAnalysisCopy.Cells(intAnalysisRow,4)="FAIL"
intFalseCount=intFalseCount+1
objAnalysisCopy.Cells(intAnalysisRow,4).font.color=vbRed
End If
Exit For
End If
Next
Next
objSummary.Cells(5,2)=intAnalysisRowCount-intReportingRowCount
objSummary.Cells(6,2)=intAnalysisColCount-intReportingColCount
objSummary.Cells(7,2)=intFalseCount
objSummary.Cells(7,2).font.color=vbRed
objWorkbook.Save
objWorkbook.Close
objExcel.Quit
EndTime=Timer()
TotalTime=EndTime-startTime
msgbox "Data Comparision is Completed. Comparision time is "&TotalTime&"Secs"
End If
Use a dictionary and you avoid the nested loops and only scan each sheet once. For example as a VBA macro (untested)
Sub compare()
Dim wb As Workbook
Dim ws(2) As Worksheet, wsSum As Worksheet, wsCopy As Worksheet
Dim rowCount(2) As Long, colCount(2) As Integer, colMetric(2) As Integer
Dim colsMetric(2) As String, colsAll(2) As String, colsKeys(2) As String
Dim bMetricsFlag As Boolean, bColCountFlag As Boolean, bColOrderFlag As Boolean
Dim i As Long, ar, msg As String, intFalseCount As Long
Dim t0 as Single
t0 = Timer
Set wb = ThisWorkbook
Set ws(1) = wb.Sheets("Analysis")
Set ws(2) = wb.Sheets("Reporting")
Set wsSum = wb.Sheets("Summary")
wsSum.Cells.Clear
wsSum.Range("A1:A7") = WorksheetFunction.Transpose(Array("Analysis Row Count", _
"Reporting Row Count", "Analysis Column Count", "Reporting Column Count", _
"Difference of Row Count", "Difference of Column Count", "False Count"))
Set wsCopy = wb.Sheets("Analysis_Copy")
wsCopy.Cells.Clear
' get stats for each sheet 1-Analyis 2=Reporting
For i = 1 To 2
ar = Stats(ws(i))
rowCount(i) = ar(0)
colCount(i) = ar(1)
colMetric(i) = ar(2)
colsAll(i) = ar(3)
colsMetric(i) = ar(4)
colsKeys(i) = ar(5)
Next
' summary
With wsSum
.Cells(1, 2) = rowCount(1)
.Cells(2, 2) = rowCount(2)
.Cells(3, 2) = colCount(1)
.Cells(4, 2) = colCount(2)
End With
' check stats
'Metric' column number must be same
If colMetric(1) = 0 Or colMetric(2) = 0 Or colMetric(1) <> colMetric(2) Then
msg = "Metrics columns not the same or missing : " & vbCr & _
"Analysis : " & colMetric(1) & vbCr & _
"Reporting : " & colMetric(2)
MsgBox msg, vbCritical
bMetricsFlag = False
Else
bMetricsFlag = True
End If
' Verify count of columns
If colCount(1) <> colCount(2) Then
msg = "Column counts not the same : " & vbCr & _
"Analysis : " & colCount(1) & vbCr & _
"Reporting : " & colCount(2)
MsgBox msg, vbCritical
bColCountFlag = False
Else
bColCountFlag = True
End If
'Verify Order of columns
If colsAll(1) <> colsAll(2) Then
msg = "Column order not the same : " & vbCr & _
"Analysis : " & colsAll(1) & vbCr & _
"Reporting : " & colsAll(2)
MsgBox msg, vbCritical
bColOrderFlag = False
Else
bColOrderFlag = True
End If
With wsCopy
.Cells(1, 1) = colsKeys(1)
.Cells(1, 2) = "Analysis_" & colsMetric(1)
.Cells(1, 3) = "Reporting_" & colsMetric(2)
.Cells(1, 4) = "Status"
End With
' checks OK ?
If bColOrderFlag And bMetricsFlag And bColCountFlag Then
' ok
Else
MsgBox "So Data Comparision can not be done", vbCritical
Exit Sub
End If
' start comparison
Dim dict As Object, m As Long, c As Long, s As String
Dim sKey As String, sMetric As String
Set dict = CreateObject("Scripting.Dictionary")
' scan Reporting sheet to build dictionary
m = colMetric(2)
For i = 1 To rowCount(2)
'join cols up to and after metric col
sMetric = "": sKey = ""
For c = 1 To colCount(2)
s = Trim(ws(2).Cells(i, c))
If c < m Then
If sMetric <> "" Then sMetric = sMetric & "*"
sMetric = sMetric & s
ElseIf c > m Then
If sKey <> "" Then sKey = sKey & "*"
sKey = sKey & s
End If
Next
dict(sKey) = sMetric
Next
' scan Analysis sheet to compare dictionary
m = colMetric(1)
For i = 2 To rowCount(1)
'join cols up to and after metric col
sMetric = "": sKey = ""
For c = 1 To colCount(1)
s = Trim(ws(1).Cells(i, c))
If c < m Then
If sMetric <> "" Then sMetric = sMetric & "*"
sMetric = sMetric & s
ElseIf c > m Then
If sKey <> "" Then sKey = sKey & "*"
sKey = sKey & s
End If
Next
' result
wsCopy.Cells(i, 1) = sKey
wsCopy.Cells(i, 2) = sMetric
wsCopy.Cells(i, 3) = dict(sKey)
' pass or fail
If sMetric = dict(sKey) Then
wsCopy.Cells(i, 4) = "PASS"
wsCopy.Cells(i, 4).Font.Color = vbGreen
Else
wsCopy.Cells(i, 4) = "FAIL"
wsCopy.Cells(i, 4).Font.Color = vbRed
intFalseCount = intFalseCount + 1
End If
Next
With wsSum
.Cells(5, 2) = rowCount(1) - rowCount(2)
.Cells(6, 2) = colCount(1) - colCount(2)
.Cells(7, 2) = intFalseCount
.Cells(7, 2).Font.Color = vbRed
End With
MsgBox i - 2 & " rows scanned " & vbCrLf & _
intFalseCount & " FAILED", vbInformation, Int(Timer - t0) & "seconds"
End Sub
Function Stats(ws As Worksheet) As Variant
Dim c As Integer, ar(5) As Variant, s As String
ar(0) = ws.UsedRange.Rows.Count
ar(1) = ws.UsedRange.Columns.Count
ar(2) = 0 'metric column
ar(3) = "" ' col aggregated
ar(4) = "" ' cols upto not including metric
ar(5) = "" ' cols after metric
For c = 1 To ar(1)
s = LCase(Trim(ws.Cells(1, c)))
If s = "metric" Then
ar(2) = c
End If
' aggregate headers before/after metric
If ar(2) = 0 Then
If ar(4) <> "" Then ar(4) = ar(4) & "*"
ar(4) = ar(4) & s
ElseIf c > ar(2) Then
If ar(5) <> "" Then ar(5) = ar(5) & "*"
ar(5) = ar(5) & s
End If
' aggregate all
If ar(3) <> "" Then ar(3) = ar(3) & "*"
ar(3) = ar(3) & s
Next
Stats = ar
End Function
Test data generator
Sub testdata()
Dim ws As Worksheet, n, r, c, ar
ar = Array("", "Analysis", "Reporting")
For n = 1 To 2
Set ws = Sheets(ar(n))
For r = 1 To 30000
For c = 1 To 15
ws.Cells(r, c) = Chr(64 + c) & r & "_abcdefghijklmnopqrstuvwxyz_"
Next
Next
ws.Cells(1, 10) = "metric" ' col J
Next
MsgBox "test data created"
End Sub
I'm working on a script that pings computers from a list periodically and returns information.
My problem is, whenever the the script is running, it steals focus from other excel windows.
For example if if I'm typing in another workbook when the scrip runs, it jumps (to the cell that was last selected) and continues writing in the cell.
Here is the script:
Sub autoping_cb()
Dim c As Range
Dim thePing As Variant
Dim TryCount As Integer
Dim TryAgainCount As Integer
Dim TryNextRun As Boolean
TryNextRun = False
Set sht = Application.ThisWorkbook.Worksheets(1)
LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
Dim chb As Shape
Set chb = ThisWorkbook.Worksheets(1).Shapes("autoping")
If chb.ControlFormat.Value = xlOn Then
sht.Range("H3").Value = Replace(sht.Range("H3").Value, ",", ".")
TryCount = 1
If sht.Range("H4") <> "" And IsNumeric(sht.Range("H4")) = True And sht.Range("H4") = Int(sht.Range("H4")) And sht.Range("H3") <> "" And IsNumeric(sht.Range("H3")) = True Then
TryAgainCount = sht.Range("H4").Value
If TryAgainCount = 0 Then
TryNextRun = True
End If
Do Until chb.ControlFormat.Value = xlOff
Wait ThisWorkbook.Worksheets(1).Range("H3").Value * 60 '<-- replace to 60 after testing
For Each c In Application.Worksheets(1).Range("B3:B" & LastRow)
If chb.ControlFormat.Value = xlOff Then
End
ElseIf chb.ControlFormat.Value = xlOn Then
If ispcname(c.Value) = True Or isip(c.Value) = True Then
If c.Offset(0, 2) = "--->" And TryNextRun = False Then
Else
c.Offset(0, 1) = nslookup(c.Value)
thePing = sPing(c.Value)
c.Offset(0, 2) = thePing(0)
c.Offset(0, 3) = GetErrorCode(thePing(1))
If c.Offset(0, 2).Value = "--->" Then
sht.Range("B" & c.Row & ":E" & c.Row).Style = "Bad"
ElseIf c.Offset(0, 2).Value < 50 Then
sht.Range("B" & c.Row & ":E" & c.Row).Style = "Good"
Else
sht.Range("B" & c.Row & ":E" & c.Row).Style = "Neutral"
End If
End If
End If
End If
sht.Range("B2:E" & LastRow + 1).Columns.AutoFit
Next c
If TryNextRun = False And TryCount < TryAgainCount Then
TryCount = TryCount + 1
Debug.Print 1
ElseIf TryNextRun = False And TryCount >= TryAgainCount Then
TryNextRun = True
TryCount = 1
Debug.Print 2
ElseIf TryNextRun = True And TryAgainCount <> 0 Then
TryNextRun = False
Debug.Print 3
End If
Loop
Else
MsgBox "invalid 'Ping every'/'try offline after' integer"
End If
End If
End Sub
It's a bit messy I know :-)
Beacuse all excel sheets are running on one thread (one Excel.exe instance, you can see one presence in task manager).
If you are running more excel instance, your sheet are working independently.
You can do one of these possibilities :
-simple open new Excel.exe from start menu, icon, etc
-windows tray excel icon right click then alt+click on Microsoft Excel
-start command (or shortcut or batch file): Excel.exe "xls path" /x
-vba
Sub OpenNewExcelInstance()
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
xlApp.Workbooks.Add
xlApp.Visible = True
Set xlApp = Nothing
End Sub
-modify your registry to force open in new instance
-modify your Personal.xlsb
i think the easiest solution is to use the task -scheduler, and start your macro from there. In the extend properties choose "run whether user is logged on or not", then this is started in a separate task.
I have an excel document that runs a VBA script that I use user forms to input data. The script works fine, except for the grouping. There are 2 groups. The first is at the Customer Name, which works fine. The second is at the Effort Name, which does not. It groups the effort, but when grouped it still displays the last row. The developer I hired to write the script said that this error appears to be a bug in Excel or for some reason by design when two groups have the same last row.
Does anyone have a solution?
Images show the macros script and grouping Image of marcos
Image of grouping
Below is the VBA script that was written for creating the effort via user form.
Private Sub ButtonAddEffort_Click()
Dim c As Object
Dim sht As Worksheet
Dim foundrow As Long
Dim blassign As Boolean
Dim x As Long
Dim rowstart As Long
Dim rowend As Long
Dim i As Long
Dim rowstarteffort As Long
If IsNull(Me.txtProjectNumberLocate) Or Me.txtProjectNumberLocate = "" Then
MsgBox "Please enter a project number."
Me.txtProjectNumberLocate.SetFocus
Exit Sub
End If
If IsNull(Me.txtEffortName) Or Me.txtEffortName = "" Then
MsgBox "Please enter an effort name."
Me.txtEffortName.SetFocus
Exit Sub
End If
If Not IsNull(Me.txtStartDate) And Me.txtStartDate <> "" Then
If Not IsDate(Me.txtStartDate) Then
MsgBox "Please enter a valid start date in 'mm/dd/yyyy' format."
Me.txtStartDate.SetFocus
Exit Sub
End If
End If
If Not IsNull(Me.txtFinishDate) And Me.txtFinishDate <> "" Then
If Not IsDate(Me.txtFinishDate) Then
MsgBox "Please enter a valid finish date in 'mm/dd/yyyy' format."
Me.txtFinishDate.SetFocus
Exit Sub
End If
End If
Set sht = Sheets("Sheet1")
Set c = sht.Range("F:F").Find(what:=Me.txtProjectNumberLocate, after:=sht.Cells(1, 6), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not c Is Nothing Then
foundrow = c.Row
rowstart = foundrow
rowstarteffort = foundrow
Else
foundrow = 0
End If
If foundrow = 0 Then
MsgBox "Could not find project # " & Me.txtProjectNumberLocate
Exit Sub
End If
''any efforts exist1
Set c = sht.Range("A:A").Find(what:="*", after:=sht.Cells(foundrow, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
foundrownext = c.Row
Else
foundrownext = 0
End If
If foundrownext > foundrow Then
foundrow = foundrownext - 1
End If
'check work order format
For x = 1 To 8
If Not IsNull(Me("txtworkorder" & x)) And Me("Txtworkorder" & x) <> "" Then
If Me("CheckBox" & x) = True Then
If Len(Me("txtWorkOrder" & x)) <> 8 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Me("txtWorkOrder" & x), "-") = 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If Mid(Me("txtworkorder" & x), 5, 1) <> "-" Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Left(Me("txtWorkOrder" & x), 4), "-") <> 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Right(Me("txtWorkOrder" & x), 3), "-") <> 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
End If
End If
Next x
i = 0
If foundrownext > 1 Then
sht.Rows(rowstart + 1 & ":" & foundrownext - 1).Select
On Error Resume Next
Selection.Rows.Ungroup
On Error GoTo 0
End If
blassign = False
For x = 8 To 1 Step -1
If Me("CheckBox" & x) = True Then
blassign = True
End If
Next x
If blassign = False Then
sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
sht.Range("B" & foundrow + 1) = Me.txtEffortName
sht.Range("B" & foundrow + 1).Font.Color = 13998939
sht.Range("B" & foundrow + 1).Font.Underline = True
sht.Range("I" & foundrow + 1) = Me.txtStartDate
sht.Range("J" & foundrow + 1) = Me.txtFinishDate
i = 1
Else
sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
sht.Range("B" & foundrow + 1) = Me.txtEffortName
sht.Range("B" & foundrow + 1).Font.Color = 13998939
sht.Range("B" & foundrow + 1).Font.Underline = True
sht.Range("I" & foundrow + 1) = Me.txtStartDate
sht.Range("J" & foundrow + 1) = Me.txtFinishDate
For x = 8 To 1 Step -1
If Me("CheckBox" & x) = True Then
sht.Range(foundrow + 2 & ":" & foundrow + 2).EntireRow.Insert shift:=xlDown
sht.Range("F" & foundrow + 2) = Me("txtWorkOrder" & x)
sht.Range("G" & foundrow + 2) = Me("cmbAssign" & x)
i = i + 1
End If
Next x
End If
''group new efforts
If foundrownext <= 1 Then
foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group
''ungroup and group old project data
rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group
''
MsgBox "Done!"
End Sub
Private Sub ButtonClose_Click()
Unload Me
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub ComboBox2_Change()
End Sub
Private Sub ComboBox3_Change()
End Sub
Private Sub ComboBox4_Change()
End Sub
Private Sub TextBox9_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Outline (group) in Excel requires a summary row, that depending on the settings you have in your computer, should be placed below (default) or above each outline level.
Your situation
What's happening in your spreadsheet is that you currently have the default settings, i.e. summary row should be below the current outline level. And you're grouping the rows 9,10 and 13.
My guess here is that the developer tried to group effort 1 and effort 2 and it didn't work, because to group effort 2 without leaving an additional row would just look like this:
Note: See the 4 dots on the right of rows 13 to 16
The Excel solution
In this case, you need to toggle the settings so the summary rows are above the detail
How to adjust the settings
Outline settings:
Current configuration:
Adjusted configuration
This would allow to have the summary row above details like this:
And when collapsed:
The VBA solution
Now, about the VBA code you have, although it can certainly be improved, I understand it accomplishes your requirements.
I suggest to specially check these two blocks:
Block # 1:
''group new efforts
If foundrownext <= 1 Then
foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group
Block #2
''ungroup and group old project data
rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group
I'd suggest the developer to read this article on how and why to avoid select in Excel VBA.
Please let me know if the solution works and remember to mark the answer (tick the check mark at the left) if it does.
Currently I'm creating a check for a column.
Goal: I have a column called currency which I need to check if they are all the same for each Bank (Column A). If there are other currency then it will prompt me.
Additional goal: I would also like to include in the checking the one in column E (Currency (Bank Charge)) to make sure that all currencies for that bank are the same.
Problem: I already have a working code using scripting.dictionary, however, I have some trouble clearing the dictionary for the first loop / currencies for the first Bank. I tried to clear the dictionary before it proceeds to another bank. But it is not working.
Below is the screenshot of what I would like to check:
Below is the current code that I have:
Sub CurrencyTestCheck()
Dim wksSource As Worksheet: Set wksSource = ThisWorkbook.Sheets("Test1")
Dim i As Long
Dim x As Long
Dim lastRow As Long
Dim strBankName As String
Set d = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
lastRow = wksSource.Cells(wksSource.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastRow
If Len(wksSource.Cells(i, 1).Value) > 0 Then 'If a new bank starts
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
countCurrency = d(k)
msg = msg & strCheck & " - " & countCurrency & vbNewLine
x = x + 1
Next k
If x > 1 Then
MsgBox "There are different currencies for bank " & strBankName & vbNewLine & _
vbNewLine & msg, vbCritical, "Warning"
Else
MsgBox "Currencies are all the same for " & strBankName, vbInformation, "Same currencies"
End If
d.RemoveAll
End If
strBankName = wksSource.Cells(i, 1).Value
End If
'Currency for each Bank
tmp = Trim(wksSource.Cells(i, 3).Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next i
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
countCurrency = d(k)
msg = msg & strCheck & " - " & countCurrency & vbNewLine
x = x + 1
Next k
If x > 1 Then
MsgBox "There are different currencies for bank " & strBankName & vbNewLine & _
vbNewLine & msg, vbCritical, "Warning"
Else
MsgBox "Currencies are all the same for " & strBankName, vbInformation, "Same currencies"
End If
End If
Application.ScreenUpdating = True
End Sub
Output:
Previous values are still in the dictionary (USD - 3 and AUD - 2)
Appreciate if you also have another suggestion to do the checking.
You might have forgotten to reset your currency discrepancy counter x.
Set it to x = 0 after the first bank's loop.
i.e.
...
...
'Currency for each Bank
tmp = Trim(wksSource.Cells(i, 3).Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next i
' Add these two lines:
x = 0
msg = ""
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
...
...
And like TinMan said, also reset the msg so the previous bank's results don't leak into your the next bank.