When reading down a column of Excel file, how to define cell coordinates without selecting a cell? - excel

Can anyone tell me how to improve this macro?
All the macro does is it just reads an Excel file for a list a accounts to update in an application (SmarTerm Beta). It technically already accomplishes the goal, but is there a way to code it so that while it’s reading the Excel file, the coordinates of the cells from which to read the account numbers and also the coordinates of the cells in which to write an output don’t depend on a "pre-selected" a cell? The risk with selecting a cell is that if someone were to accidentally select a different cell while the macro is running, everything will get screwed up.
Here's my current code:
Public oExcelObj As Object
Function WaitSystem(Optional NoDialog as Variant) As Boolean
Dim nContinue as Integer
Dim nTimeOut as Integer 'In seconds.
'The default timeout for each command is 3 minutes.
'Increase this value if your host requires more time
'for each command.
nTimeOut = 10
If IsMissing(NoDialog) then NoDialog = False
'Wait for response from host.
Session.EventWait.Timeout = nTimeOut
Session.EventWait.EventType = smlPAGERECEIVED
Session.EventWait.MaxEventCount = 1
WaitSystem = True
If Session.EventWait.Start = smlWAITTIMEOUT Then
If NoDialog Then
WaitSystem = False
Else
nContinue = QuerySyncError()
If nContinue <> ebYes then WaitSystem = False
End If
End If
Set LockStep = Nothing
End Function
'Establish link. Search for Excel.
Function OleLinkConnection
Const XlMaximized = &HFFFFEFD7
Titlebar$ = AppFind$("Microsoft Excel")
If Titlebar$ <> "" Then
bIsExcelActive = True
If AppGetState(Titlebar$) = ebMinimized Then
AppSetState 2, Titlebar$
End If
Else
bIsExcelActive = False
End If
If bIsExcelActive Then
'Create Excel Object using current instance of Excel.
Set oExcelObj = GetObject(, "Excel.Application")
Else
'Create Excel Object using a new instance of Excel.
Set oExcelObj = CreateObject("Excel.Application")
End If
Version = oExcelObj.Application.Version
oExcelObj.ScreenUpdating = True
oExcelObj.Displayalerts = True
oExcelObj.Visible = true
End Function
Sub JPBmacro
Dim AccountNumber As String
Dim Temp As Integer
Begin Dialog StartDialogTemplate ,,211,74,"Run JPBmacro?"
OKButton 60,12,92,20,.Proceed
CancelButton 60,40,92,20,.Exit
End Dialog
Dim StartDialog As StartDialogTemplate
r% = Dialog(StartDialog)
If r% = 0 Then End
g$ = "G:\DATA\outputfile.xlsx"
oleCode = OleLinkConnection
oExcelObj.Workbooks.Open g$
oExcelObj.Range("A1").Select ‘<----This selects the cell from which all coordinates are based off of. The coordinates of oExcelObj.ActiveCell.Offset(Y,X).Value VBA depend on selecting a cell.
NEXTACCOUNT:
Temp = 0
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
While AccountNumber <> ""
Session.SendKey "CLEAR"
If WaitSystem = False Then End
Session.Send "ACTU " & AccountNumber
Session.SendKey "ENTER"
If WaitSystem = False Then End
If Trim(Session.ScreenText(4,6,1,22)) = "INVALID ACCOUNT NUMBER" Or Trim(Session.ScreenText(4,6,1,19)) = "ACCOUNT NOT ON FILE" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(4,6,1,22))
GoTo RESTARTLOOP
End If
UPDATEIOV:
If Trim(Session.ScreenText(13,76,1,1)) = "Y" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = "Account already flagged as institutional."
Else
Session.Row = 13
Session.Column = 76
Session.send "Y"
Session.SendKey "ENTER"
If WaitSystem = False Then End
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(24,2,1,50))
End If
RESTARTLOOP:
Temp = Temp + 1
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
Wend
ENDNOW:
oExcelObj.Workbooks.Close
MsgBox "All Done!"
End Sub

Why not keep the reference to the first cell?
Dim rng as Range
Set rng = oExcelObj.Range("A1")
i=1
...
x = rng.Cell(i,1).Value
'Or faster yet is reading all the values into an variant array.
Dim array() as Variant
array = rng.Resize(N,M).Value
' Work with array as
x = array(i,1)

Given the comment from assylias and that another poster has since "answered" with this approach:
I can't see where oExcelObj is instantiated? Or how you are referring to a specific sheet.
Regardless of which,
you can avoid select by setting a range, ie Set rng1 = oExcelObj.Sheets(1).Range("A1")
and then use offsets from rng1.
The user won't be able to interfere while the code is running

Related

Is there a way to copy the selected text within a text box with VBA Excel?

I have replaced the ctrl+c shortcut with a macro that performs additional instructions when copying a range.
When the selection is not a range, the program should simply copy the current selection. It seemed to work perfecly fine until I tried to copy some text from within a TextBox (and basically any text that is within an object). When pasting, it just pastes the object and not the selected text within the object.
Here's my code :
Sub ShadowCopy()
Dim Rg As Range, Source As Range
Dim Ad As String, Nm As String, flag As Integer, i As Integer, obj As Integer
Dim Hs As Integer, Ls As Integer, y As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
obj = 0
If TypeName(Selection) <> "Range" Then
Selection.Copy
obj = 1
Else
If Application.CutCopyMode = False Then
Set Source = Application.Selection
Nm = Source.Worksheet.name
Hs = Application.Min(Source.Rows.Count, 1000)
Ls = Application.Min(Source.Columns.Count, 1000)
Ad = Source.Address
flag = 0
For i = 1 To ActiveWorkbook.Worksheets.Count
If ActiveWorkbook.Worksheets(i).name = "ShadowCopy" Then
Sheets("ShadowCopy").Columns(1).Clear
Sheets("ShadowCopy").Columns(3).Clear
flag = 1
End If
Next i
If flag = 0 Then
Sheets.Add(After:=Sheets(Sheets.Count)).name = "ShadowCopy"
Source.Worksheet.Activate
End If
Worksheets("ShadowCopy").Visible = False
Sheets("ShadowCopy").Cells(1, 1) = Nm
Sheets("ShadowCopy").Cells(2, 1) = Ad
Sheets("ShadowCopy").Cells(3, 1) = Hs
Sheets("ShadowCopy").Cells(4, 1) = Ls
For y = 1 To Hs
Sheets("ShadowCopy").Cells(y, 3) = Source.Rows(y).RowHeight
Next y
End If
End If
Application.Calculation = xlCalculationSemiautomatic
Application.ScreenUpdating = True
If obj = 0 Then
Source.Copy
End If
End Sub
The part that does not work as intended is:
If TypeName(Selection) <> "Range" Then
Selection.Copy
obj = 1
It is as if the selection does not change when I select the text in the TextBox. However, when I recorded the text selection, the corresponding code implies that my selection should have changed when I selected the text in the TextBox:
ActiveSheet.Shapes.Range(Array("TextBox Source")).Select
Is there a way to copy the text highlighted by the cursor in a TextBox/Object ?
Thank you for your answers !

Looping along named ranges in VBA with a hidden =true/false output for the range itself, not the data within the range

I have named a number of columns as ranges e.g.
DesCond1, DesDiff1, Comparison1, DesCond2, DesDiff2, Etc...
I have some buttons which use a macro to toggle the different columns visible or hidden. I have added the code I am using for one of these buttons.
Currently I have written the code to show or hide each range individually but I would like a code that will count the number of ranges with a similar name (DesCond1, DesCond2.. DesCond(n))and then loop through each one automatically checking the hidden status so I don't have to add to the code everytime I add more data. Here is my code so far. This works fine so far.
Sub ComparisonToggle1()
Dim ComparisonAll As Range, R_Cond As Range, R_Diff As Range
'set first of each range as identifier for decisions
Set R_Comp = Range("Comparison1")
'set all ranges under one name
Set CompAll = Union(Range("Comparison1"), Range("Comparison2"), Range("Comparison3")) 'name and add when new tests are added
If R_Comp.EntireColumn.Hidden = False Then 'False
CompAll.EntireColumn.Hidden = True 'hide all
ElseIf R_Comp.EntireColumn.Hidden = True Then 'True
CompAll.EntireColumn.Hidden = False 'vis all
End If
End Sub
Sub DesignToggle1()
Dim DesCondAll As Range, DesDiffAll As Range, R_Cond As Range, R_Diff As Range
'set first of each range as identifier for decisions
Set R_Cond = Range("DesCond1")
Set R_Diff = Range("DesDiff1")
'set all ranges under one name
Set DesCondAll = Union(Range("DesCond1"), Range("DesCond2"), Range("DesCond3"), Range("DesCond4"), Range("DesCond5"), Range("DesCond6")) 'name and add when new tests are added
Set DesDiffAll = Union(Range("DesDiff1"), Range("DesDiff2"), Range("DesDiff3"), Range("DesDiff4"), Range("DesDiff5"), Range("DesDiff6")) 'name and add when new tests are added
If R_Cond.EntireColumn.Hidden = False And R_Diff.EntireColumn.Hidden = False Then 'False/False
DesCondAll.EntireColumn.Hidden = True 'both hidden
DesDiffAll.EntireColumn.Hidden = True
ElseIf R_Cond.EntireColumn.Hidden = True And R_Diff.EntireColumn.Hidden = False Then 'True/False
DesCondAll.EntireColumn.Hidden = False 'vis both
DesDiffAll.EntireColumn.Hidden = False
ElseIf R_Cond.EntireColumn.Hidden = False And R_Diff.EntireColumn.Hidden = True Then 'False/True
DesCondAll.EntireColumn.Hidden = False 'vis both
DesDiffAll.EntireColumn.Hidden = False
ElseIf R_Cond.EntireColumn.Hidden = True And R_Diff.EntireColumn.Hidden = True Then 'True/True
DesCondAll.EntireColumn.Hidden = False 'vis both
DesDiffAll.EntireColumn.Hidden = False
End If
End Sub
This is to loop through all the names in your workbook, thought you need to give it the group you want to filter:
Option Explicit
Sub Test(Group As String)
Dim MyName As Name
For Each MyName In ThisWorkbook.Names
If MyName.Name Like "*" & Group & "*" Then
Range(MyName).EntireColumn.Hidden = True
End If
Next MyName
End Sub
Sub Main()
'This procedure calls the Test procedure feeding the variable Group as "Descond"
Test "Descond"
End Sub

Access to Excel: Decrease Runtime of Excel VBA

Similar versions of this question probably have been asked before, but I had questions regarding this issue.
Basically for my function, I just want to run simple a spell check on selected tables from Microsoft Access. Since Access doesn't support individual highlighting all too well in reports, I have the data exported to an Excel file and have VBA run tests for any errors there. After searching online for tips, I have the current code to run faster than what I originally had. But ideally no matter the size of the table I want the function to run under 10 minutes. But currently for some of them, for tables that have 500k+ cells the runtime can still go past 30 minutes. So I was wondering if anything further can be done to better enhance the runtime of this.
Private Function Excel_Parser(outFile As String, errorCount As Integer, ByVal tName As String)
' EXCEL SETUP VARIABLES
Dim OpenApp As Excel.Application
Set OpenApp = CreateObject("Excel.Application")
Dim parserBook As Excel.Workbook
Dim parserSheet As Excel.Worksheet
' Opening exported file
Set parserBook = OpenApp.Workbooks.Open(outFile, , , , , , , , , , , , , , XlCorruptLoad.xlRepairFile)
If parserBook Is Nothing Then
status2 = "Failed to set Workbook"
Exit Function
Else
status3 = "Searching [" & tName & "] for errors"
Set parserSheet = parserBook.Worksheets(1)
' --------------------------------------------------------------------------------
' Fetch Table information
lastCellAddress = parserSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Address
Dim rng As Range
Set rng = parserSheet.Range("A1:" & lastCellAddress)
' --------------------------------------------------------------------------------
' Populating entire table data from Excel into array to save runtime.
Dim dataArr() As Variant, R As Long, C As Long
dataArr = rng.Value2
' Parsing through table data array
nRows = UBound(dataArr, 1)
nCols = UBound(dataArr, 2)
fileOuterLoop1 = Time
For R = 1 To nRows
For C = 1 To nCols
cCell = CStr(dataArr(R, C))
status4 = "Now running check on cell: [" & cCell & "]"
If cCell <> "" Or Not (IsNull(cCell)) Then
If Not OpenApp.Application.CheckSpelling(cCell) Then
errorCount = errorCount + 1
' Change cell status
vArr = Split(parserSheet.Cells(1, C).Address(True, False), "$")
fCol = vArr(0)
xDef = fCol & R
parserSheet.Range(xDef).Interior.Color = RGB(255, 213, 124)
End If
End If 'End of cCell is null check
Next C
Next R
fileOuterLoop2 = Time
fCheck = Format(fileOuterLoop2 - fileOuterLoop1, "hh:mm:ss")
' --------------------------------------------------------------------------------
parserSheet.Columns.AutoFit
status7 = "Loop Finished. Runtime: " & fCheck
' Save and Cleanup
OpenApp.DisplayAlerts = False
parserBook.SaveAs FileName:=outFile, FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
parserBook.Saved = True
parserBook.Close SaveChanges:=False
OpenApp.DisplayAlerts = True
Set parserSheet = Nothing
Set parserBook = Nothing
Set OpenApp = Nothing
' Return errorCount for database
Excel_Parser = errorCount
End If
End Function
outFile is a PATH string, where file exists from a TransferSpreadsheet command. And "status" variables are just error log textboxes in the Access form. I have tried adding in both Access' and Excel's versions of ScreenUpdating or Echo but I found that these commands actually make my function runtime slightly slower.
Two things:
Do you use status4 somewhere in your code to show current state of work and just omitted it here in the sample? If so, think about not displaying it for every loop, but maybe only every 50 steps by using Mod operator.
See https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/mod-operator
You should avoid screen refreshs and more on every loop in Excel by setting this before the loop:
OpenApp.ScreenUpdating = False
OpenApp.EnableEvents = False
OpenApp.Calculation = Excel_XlCalculation.xlCalculationManual
And this after the loop:
OpenApp.ScreenUpdating = True
OpenApp.EnableEvents = True
OpenApp.Calculation = Excel_XlCalculation.xlCalculationAutomatic
It can end in a massive speed up. Give it a try.

Why do I get run-time error -2147417848 (80010108) in excel 2013 most of the time I run UserForm?

Task:
I work in Excel2013. I tried to write in VBA a userform to add parameters into dynamic named ranges. All named ranges are held in one sheet and were created using insert>table. I select the range, show existing values and get the new value. All went well untill I actually got to adding value to the range.
Problem:
Excel shuts down most of the time when I try to run the UserForm. Saying:
"Run-time error '-2147417848 (80010108)' Method X of object 'Range' failed"
with different methods ('_Default' last time I checked) at different stages of me breaking code down.
Symtoms:
After this line as I found I get the error:
Cells(y, x) = v
where y and x are integers and v a string I get from the userform. During the debug I checked all values are defined and have values. Moreover, Immediate window with the same numbers input manually (not as variables), works!
It mostly doesn't work, though it did follow through doing the job.
If somone could tell the reason why it breaks it would be greatly appreciated!
Some of the captions and potential values are in Unicode in case it matters, though I tried putting it all in English as well.
Private Sub UserForm_Initialize()
' Preparing all controls of UserForm
Sheet2.Activate
Me.LB_parameter.SetFocus
Me.LB_parameter.value = ""
Me.LB_elements.RowSource = ""
Me.L_element.Enabled = False
Me.TB_element.Enabled = False
Me.TB_element.Locked = True
Me.Btn_Add.Enabled = False
Me.Btn_Add.Locked = True
End Sub
Private Sub LB_parameter_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' Filling the existing list of values for the selected parametr
If Me.LB_parameter.value <> "" Then
Me.LB_elements.RowSource = "D_" & Me.LB_parameter.value & "s"
Me.L_element.Enabled = True
Me.TB_element.Enabled = True
Me.TB_element.Locked = False
Me.TB_element.SetFocus
End If
End Sub
Private Sub TB_element_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' Catching the event of filling out the potential new value
Me.Btn_Add.Enabled = True
Me.Btn_Add.Locked = False
Me.L_element.Enabled = False
Me.TB_element.Enabled = False
Me.TB_element.Locked = True
End Sub
Private Sub Btn_Add_Click()
If Me.TB_element.Text = "" Then
' Check if Empty
MsgBox ("Âû íå âïèñàëè çíà÷åíèå!")
' Reset the UserForm
Me.Btn_Add.Enabled = False
Me.Btn_Add.Locked = True
Me.L_element.Enabled = True
Me.TB_element.Enabled = True
Me.TB_element.Locked = False
Me.TB_element.SetFocus
Else
' check if exists
Dim str
For Each str In range("D_" & Me.LB_parameter.value & "s")
If Me.TB_element.Text = str Then
MsgBox ("Ââåäåííîå çíà÷åíèå óæå ñóùåñòâóåò!")
' reset the UserForm
Me.Btn_Add.Enabled = False
Me.Btn_Add.Locked = True
Me.L_element.Enabled = True
Me.TB_element.Enabled = True
Me.TB_element.Locked = False
Me.TB_element.SetFocus
Me.TB_element.value = ""
Exit Sub
End If
Next str
' add to the range here
Dim x As Integer, y As Integer, v As String
y = range("D_" & Me.LB_parameter.value & "s").Rows.Count + 2
x = Me.LB_parameter.ListIndex + 1
v = Me.TB_element.value
' Next line causes break down
Cells(y, x) = v
MsgBox ("Âû äîáàâèëè ýëåìåíò:'" & v & "' äëÿ ïàðàìåòðà '" & Me.LB_parameter.value & "'.")
' Reset the Userform
Me.LB_parameter.SetFocus
Me.LB_parameter.value = ""
Me.LB_elements.RowSource = ""
Me.L_element.Enabled = False
Me.TB_element.Enabled = False
Me.TB_element.Locked = True
Me.Btn_Add.Enabled = False
Me.Btn_Add.Locked = True
End If
End Sub
Sheet I add values to the parametrs and namedranges window:
The UserForm layout:
Cells(y, x) = v
This call is shorthand for this:
ActiveSheet.Cells(y, x).Value = v
I'm not sure why it's crashing on you, but the _Default property of a Range object being its Value, what I'd try here is being more explicit about what I'm trying to achieve, namely:
Exactly which Worksheet is supposed to get modified?
Exactly which Range is being referred to?
I very very very seldom work with ActiveSheet - most of the time I know exactly what object I'm working with. Try using an object. You can create a new one:
Dim target As Worksheet
Set target = ThisWorkbook.Worksheets("pl")
...Or you can give the sheet a code name in the properties toolwindow (F4):
That (Name) property defines an identifier that you can use in VBA code to access a global-scope object that represents that specific worksheet. Assuming that's Sheet1, you could do this:
Sheet1.Cells(x, y) = v
If that still fails, then you can be even more specific about the Range object you're accessing and the property you're setting:
Dim target As Range
Set target = Sheet1.Cells(x, y)
target.Value = v
Normally that wouldn't make a difference though. But I see you're making Range calls, which are also implicitly calling into the ActiveSheet.
I'd start by eliminating these, and working off an explicit object reference.
Then I'd work on getting the spreadsheet logic out of the form; that button click handler is doing way too many things - but I digress into Code Review territory - feel free to post your code there when you get it to work as intended!
Looks like the problem lies in my version of Excel. Not sure if the problem is in my copy or in the 2013 in general. In Excel 2007 on the same machine the UserForm with given suggestions worked continuously without any errors at all! Will update in comments later as I try it in different versions.

Loop Through CheckBox Controls in VBA UserForm

I have a user form in Excel VBA with a check box for each month.
Selecting one or more cause the required month to be shown on the sheet, I copy-pasted the code 12 times and it works but I'm sure there is a better way doing it with a For loop.
This is a part of my code (it goes on 12 times):
If CheckBox1.Value = True Then
ActiveSheet.PivotTables("PivotTable1").PivotFields("month").PivotItems("1").Visible = True
Else
ActiveSheet.PivotTables("PivotTable1").PivotFields("month").PivotItems("1").Visible = False
End If
If CheckBox2.Value = True Then
ActiveSheet.PivotTables("PivotTable1").PivotFields("month").PivotItems("2").Visible = True
Else
ActiveSheet.PivotTables("PivotTable1").PivotFields("month").PivotItems("2").Visible = False
End If
I tried writing:
for i in range 1 to 12
and then writing my code but there seem to be a problem when I put "i" instead of the numbers.
Assuming you aren't using Tristate checkboxes, then the .Value can only be True or False, so we should be able to get away with something like this:
(Assumes your code runs inside the UserForm, so that Controls is directly accessible)
Dim mthIdx as Long
Dim nm as String
Dim c As Control
With ActiveSheet.PivotTables("PivotTable1").PivotFields("month")
For mthIdx = 1 To 12
nm = "CheckBox" & mthIdx
Set c = Controls(nm)
.PivotItems(mthIdx).Visible = c.Value
Next
End With
(The With clause isn't strictly necessary, but it's usually a good idea to resolve nested COM references as infrequently as possible)
Try this ..
Dim i As Integer
Dim sN As String
Dim chx As MSForms.CheckBox
Dim obj As OLEObject
For i = 1 to 12
sN = format(i)
Set obj = OLEObjects("CheckBox" & sN)
Set chx = obj.Object
If chx.Value = True Then
ActiveSheet.PivotTables("PivotTable" & sN).PivotFields("month").PivotItems(sN).Visible = True
Else
ActiveSheet.PivotTables("PivotTable" & sN).PivotFields("month").PivotItems(sN).Visible = False
End If
Next
I've not checked the code but this should put you along thr right path if it's not spot on though...
For i = 1 to 12
If CheckBox(i).Value = True Then
ActiveSheet.PivotTables("PivotTable1").PivotFields("month").PivotItems(i).Visible = True
Else
ActiveSheet.PivotTables("PivotTable1").PivotFields("month").PivotItems(i).Visible = False
End If
Next i

Resources