Excel VBA script - stealing focus - excel

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.

Related

Excel VBA the code failed to export pictures after the 20-22nd time export

I'm trying to make the excel macro that save a batch of NIPT result files on another sheet to image files. The code for export single image is taken at https://www.mrexcel.com/board/threads/vba-to-save-range-as-png-or-jpeg.1139047/post-5515609, with extra codes to make the automation process
Sub SaveAsJPG_Batch()
Set wbchinh_sheet = ThisWorkbook.Sheets("Raw")
Set wbin_batch = ThisWorkbook.Sheets("In_batch")
wbchinh_sheet_lastrow = Cells(Rows.Count, 1).End(xlUp).Row
wbin_batch.Activate
wbin_batch.Range("I2").Value = Worksheets("In").Range("I2").Value
x = 2
While x <= wbchinh_sheet_lastrow
wbin_batch.Range("H1").Value = wbchinh_sheet.Range("B" & x).Value
wbin_batch.Range("F4").Value = x
'Print in batch
x = x + 1
Application.Wait (Now + TimeValue("0:00:2"))
With ActiveSheet
Set CopyRange = wbin_batch.Range("A1:E34")
If Not CopyRange Is Nothing Then
Application.ScreenUpdating = False
ExportName = wbin_batch.Range("I2") & "\" & wbin_batch.Range("E1") & ".jpg"
If Not ExportName = "False" Then
CopyRange.Copy
.Pictures.Paste
Set Pic = .Pictures(.Pictures.Count)
Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
Application.CutCopyMode = False
Do
DoEvents
Pic.Copy
DoEvents
ChO.Chart.Paste
DoEvents
i = i + 1
Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)
ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
ChO.Delete
Pic.Delete
End If
Application.ScreenUpdating = True
End If
End With
Wend
End Sub
When the macro activated, it scan for sheet Raw and find the last not empty line, then proceed to place each name from cell B2 to the last cell of the B column that contains the ID. After insert the name to H1 cell on In_batch sheet, the export macro will export the range from A1 to E34 to jpg file. However, during testing I find out that from 20th to 22nd image (looks like its randomly), all images after that are blank image, no table are printed and even adding pause time not solve the problem.
I just found out why the script stopped working after image 20 to 22, its because i > 50. So I reset the count of i after finished my job
Sub SaveAsJPG_Batch()
Dim x As Integer
Dim ChO As ChartObject, ExportName As String
Dim CopyRange As Range
Dim Pic As Picture
Dim i As Long
Set wbchinh_sheet = ThisWorkbook.Sheets("Raw")
Set wbin_batch = ThisWorkbook.Sheets("In_batch")
wbchinh_sheet_lastrow = Cells(Rows.Count, 1).End(xlUp).Row
wbin_batch.Activate
wbin_batch.Range("I2").Value = Worksheets("In").Range("I2").Value
x = 2
While x <= wbchinh_sheet_lastrow
wbin_batch.Range("H1").Value = wbchinh_sheet.Range("B" & x).Value
wbin_batch.Range("F4").Value = x
'Print in batch
x = x + 1
i = 0
If Not wbin_batch.Range("H1").Value = "" Then
With wbin_batch
wbin_batch.Range("F5").Value = i
Set CopyRange = wbin_batch.Range("A1:E34")
Application.ScreenUpdating = False
ExportName = wbin_batch.Range("I2") & "\" & wbin_batch.Range("E1") & ".jpg"
CopyRange.Copy
.Pictures.Paste
Set Pic = .Pictures(.Pictures.Count)
Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
Application.CutCopyMode = False
Do
DoEvents
Pic.Copy
DoEvents
ChO.Chart.Paste
DoEvents
i = i + 1
Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)
ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
ChO.Delete
Pic.Delete
Application.ScreenUpdating = True
Application.Wait (Now + TimeValue("0:00:1"))
End With
End If
Wend
End Sub

SAP fails on 2nd iteration of loop

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

VBA Userform Listbox Conditional Logic Not Working as Intended

I have a Userform with a listbox for which I am using conditional logic to determine output values to the sheet of selected or non-selected items in the listbox. The issue is that when the Textbox (Tbl_AliasName) is blank, the code executes this:
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
But if Tbl_AliasName is not blank then the code does nothing, but it is supposed to do this:
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
I have used several variations of If statements, and non of which have worked.
Below is My Code:
Option Explicit
Public Tbl_AliasName As String
Tbl_AliasName = Trim(UserForm_Finder.txtConcat.Value)
Private Sub BtnConcat_Click()
Dim k As Long, lstbxRow As Long, LR As Long
lstbxRow = 1
'****************
'This if statement works perfectly
If (Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) _
And Tbl_AliasName = vbNullString Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf (UserForm_Finder.ListBx_TblsCols.ListCount = 0 And Tbl_AliasName <> vbNullString) Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
'(Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) And _
Exit Sub
End If
With UserForm_Finder.ListBx_TblsCols
For k = 0 To .ListCount - 1
'****************
This is where the problems begin
If .Selected(k) = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
End If
Next k
End With
End Sub
My goal is to do the following:
If a Textbox (Tbl_AliasName) is not blank and the user has selected one or more items in the listbox (ListBx_TbleCols) then concatenate the Tbl_AliasName to the selected items in the listbox
If Tbl_AliasName is blank, then use the value in Cells(2,1) to concatenate to the selected Items in the list box.
I have tried the following additions:
Dim LstBxItemSelected As Boolean
'This was placed in the for loop
LstBxItemSelected = True
'this was placed outside the for loop
If LstBxItemSelected = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
End If
Is there a better way to tell if items are selected, because I feel that the way I have it structured in my loop, the code will throw the error if everything isn't selected? Thank you in advance for any ideas, answers, or suggestions!
Note: The Listbox is populated by the click of another button on the userform which calls the following sub:
Sub FillLstBxCols()
Dim ListBx_Target As MSForms.ListBox
Dim rngSource As Range
Dim LR As Long
If Cells(2, 1).Value2 <> vbNullString Then
LR = Worksheets("New TRAX").Cells(Rows.Count, 2).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("New Trax").Range("A" & 2 & ":" & "B" & LR)
'Fill the listbox
Set ListBx_Target = UserForm_Finder.ListBx_TblsCols
With ListBx_Target
.RowSource = rngSource.Address
End With
End If
End Sub
Hard to say without sample data and expected results, but I think this is what you're looking for:
Private Sub btnConcat_Click()
Dim ws As Worksheet
Dim bSelected As Boolean
Dim sConcat As String
Dim i As Long, lRowIndex As Long
Set ws = ActiveWorkbook.Sheets("New TRAX")
lRowIndex = 1
bSelected = False
sConcat = Trim(Me.txtConcat.Text)
If Len(sConcat) = 0 Then sConcat = Trim(ws.Cells(2, "A").Value)
If Len(sConcat) = 0 Then
MsgBox "You must Search for a Table or Column first.", vbExclamation, "Error Encountered"
Exit Sub
End If
For i = 0 To Me.ListBx_TblsCols.ListCount - 1
If Me.ListBx_TblsCols.Selected(i) Then
If bSelected = False Then
bSelected = True
ws.Range("C2", ws.Cells(ws.Rows.Count, "C")).Clear 'clear previous concat results (delete this line if not needed)
End If
lRowIndex = lRowIndex + 1
ws.Cells(lRowIndex, "C").Value = sConcat & "." & Me.ListBx_TblsCols.List(i)
End If
Next i
If bSelected = False Then MsgBox "Must select at least one item from the list"
End Sub

Document when workbook last edited

I found code in a book:
Option Explicit
Sub SaveAndCLose()
Application.DisplayAlerts = False
Tabelle1.Range("A1").Value = _
"Last Edition " & Now & " from User " & Environ("Username")
ThisWorkbook.Close Savechanges:=True
Application.DisplayAlerts = True
End Sub
Is it possible to document the last 10 edits. For example: today USER X edited - Range("A1"). Next day there was another edit made Range("A2") and so on for each edition for that file.
I know that in Excel Audit Trail isn't implemented but that simple code gives information who made the last edit.
Or maybe there is a better way to implement an Audit Trail for Excel files?
A straightforward simple code might be the following code
Option Explicit
Const X = "X"
Sub SaveAndClose()
Dim rgB As Range
Dim rowX As Long
Dim auditTxt As String
Set rgB = Tabelle1.Range("B1:B10")
auditTxt = "Last Edition " & Now & " from User " & Environ("Username")
rowX = findXA(rgB)
'rowX = findX(rgB)
If rowX = 0 Then
Tabelle1.Cells(1, 1).Value = auditTxt
Tabelle1.Cells(1, 2).Value = X
ElseIf rowX = 10 Then
Tabelle1.Cells(1, 1).Value = auditTxt
Tabelle1.Cells(1, 2).Value = X
Tabelle1.Cells(rowX, 2).ClearContents
Else
Tabelle1.Cells(rowX + 1, 1).Value = auditTxt
Tabelle1.Cells(rowX + 1, 2).Value = X
Tabelle1.Cells(rowX, 2).ClearContents
End If
'' I commented this part of the code for testing purposes
'' Uncomment to save and close the file
' Application.DisplayAlerts = False
' ThisWorkbook.Close Savechanges:=True
' Application.DisplayAlerts = True
End Sub
Function findX(rg As Range) As Long
' find the X by putting the range into an array and looping through it
Dim vDat As Variant
Dim i As Long
findX = 0
vDat = WorksheetFunction.Transpose(rg)
For i = LBound(vDat) To UBound(vDat)
If UCase(vDat(i)) = X Then
findX = i
Exit Function
End If
Next
End Function
Function findXA(rg As Range) As Long
' find the X by usind ragne.find
Dim rgX As Range
Set rgX = rg.Find(X, , , , , , False)
If rgX Is Nothing Then
findXA = 0
Else
findXA = rgX.Row
End If
End Function
Code uses col A and B and it put an X into col B for the last written line. Maybe it is not a "clever" code but IMO it is just easy to follow, I hope

VBA Coding to pull data

I have 50 .xls files saved on a shared drive by the name of users. Eg: "Rahul Goswami.xls", "Rohit Sharma.xls", etc.
Each Excel file contains 2 worksheets: "Case Tracker" and "Pending Tracker".
In the "Case Tracker" worksheet users put their daily data/ daily production.
I wanted VBA code to pull the entire "Case Tracker" worksheet from all 50 Excel files in one separate Excel workbook, one below the other.
Currently I am copy-pasting the data from the Excel files to the master workbook to "Sheet1".
Can there be something where I put the date and the data will come automatically for that date from all the 50 files?
Column A to J contains the data provided below. This example is given for 1 user.
Date Advisor Userid BP URN Stage Case Type Previous Status Current status Category
10-Apr Rahul Goswami goswami 123456 98765431 1 URN New Pend abc
Sub Beachson()
Dim z As Long, e As Long, d As Long, G As Long, h As Long Dim f As String
d = 2
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.xls")
Do While Len(f) > 0
## Heading ##
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
Loop
z = Cells(Rows.Count, 1).End(xlUp).Row
For e = 2 To z
If Cells(e, 1) <> ActiveWorkbook.Name Then
Cells(d, 2) = Cells(e, 1)
Cells(1, 4) = "=Counta('" & Cells(1, 2) & "[" & Cells(e, 1) & "]Case Tracker'!I:I)"
For h = 10 To Cells(1, 4)
For G = 1 To 10
Cells(1, 3) = "='" & Cells(1, 2) & "[" & Cells(e, 1) & "]Case Tracker'!" & Chr(G + 64) & h
Cells(d, G + 2) = Cells(1, 3)
Next G
d = d + 1
Next h
End If
d = d + 1
Next e
MsgBox "collating is complete."
End Sub
I would avoid storing information in sheet, then going to VBA, then again to sheet, etc.
As for your problem of not being able to pull data when a file is open, I would suggest creating another instance of Excel.Application and opening files from it in ReadOnly mode.
This is the code which worked for me (the ability to find particular dates is also implemented):
Sub Beachson2()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim App As Object
Set App = CreateObject("Excel.Application")
Dim wsSource As Worksheet
Dim sFold As String
sFold = ThisWorkbook.Path & "\"
Dim sFile As String
Dim i As Long, j As Long
Dim cell As Range
' Setting date
Dim sInput As String, dInput As Date
sInput = Application.InputBox("Enter A Date")
If IsDate(sInput) Then
dInput = DateValue(sInput)
Else
MsgBox "Invalid date. Exiting..."
Exit Sub
End If
Application.ScreenUpdating = False
' Pulling data
i = 1
sFile = Dir(sFold & "\*.xls")
Do While sFile <> ""
If sFile <> sFold & ThisWorkbook.Name Then
Set wsSource = App.Workbooks.Open(Filename:=sFold & sFile, ReadOnly:=True).Sheets("Case Tracker")
For Each cell In wsSource.Range("A1:A" & wsSource.UsedRange.Rows.Count)
If cell.Value = CStr(dInput) Then
With ws.Cells(Rows.Count, 1).End(xlUp)
If IsEmpty(.Value2) Then
.Value2 = sFile
ElseIf .Value2 <> sFile Then
.Offset(1).Value2 = sFile
Else
'do nothing
End If
End With
If ws.Cells(Rows.Count, 2).End(xlUp).Value2 <> sFile Then
ws.Cells(i, 2).Value2 = sFile
End If
For j = 3 To 12
ws.Cells(i, j).Value = wsSource.Cells(cell.Row, j - 2).Value
Next
i = i + 1
End If
Next
wsSource.Parent.Close
End If
sFile = Dir()
Loop
Application.ScreenUpdating = True
App.Quit
MsgBox "collating is complete."
Set App = Nothing
End Sub
The code is stored in the master file.
Even in the code there is no one specific Date format defined, but I still think it is capable of causing problems. If you find problems regarding date formats, please post your used date format.

Resources