I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.
Related
I am trying to populate a one column table in excel which I can connect to power query, using vba and a one dimensional array.
So the user puts a list into a textbox where each item is seperated by a semicolon, then it brings that into the array. So far I have :
Dim arrSIOCodes As Variant
arrSIOCodes = Split(tbSIOCodes, ";")
ThisWorkbook.Sheets("CAEATFA_SIO").Activate
Call ChangeTableToArray(tbl:=ThisWorkbook.Sheets("CAEATFA_SIO").ListObjects("tblSIOCodes"), ar:=arrSIOCodes)
and I got this sub from another stack overflow post but I need to customize it to my issue and I am having trouble
Sub ChangeTableToArray(tbl As ListObject, ar)
Dim newRows As Long: newRows = 1 + UBound(ar, 1) - LBound(ar, 1)
If Not tbl.DataBodyRange Is Nothing Then tbl.DataBodyRange.EntireRow.Delete
If newRows > 1 Then tbl.HeaderRowRange.Resize(newRows - 1).Offset(2).EntireRow.Insert
tbl.HeaderRowRange.Resize(newRows, 1 + UBound(ar, 1) - LBound(ar, 1)).Offset (1).value = ar
End Sub
This is what the current code is doing:
however this is what I need it to do:
You are resizing the number of columns in the destination, but you only have one column (if you Transpose the array) to store. So do something like:
tbl.HeaderRowRange.Resize(newRows, 1).Offset (1).value = Application.Transpose(ar)
About to go into a late meeting, so I threw this together quickly and it's untested. But this is just another way to look at it:
Sub ArrayToTable(ByVal ws As Worksheet, ParamArray YourArr() As Variant)
Dim TmpArr As Variant, i As Long, LineNum As Long
TmpArr = YourArr(0)
LineNum = 1 'whatever method you use to find linenumbers
For i = LBound(TmpArr) To UBound(TmpArr)
ws.Cells(LineNum, 1).Value = TmpArr(i)
LineNum = LineNum + 1
Next
End Sub
I have a function meant to return an array which is created out of a single-column list of data. I have been using this function's return value essentially as a pseudo-global variable (LINENAMES_ARRAY) which I pass to many functions. Those functions than do checks on it such as If Len(Join(LINENAMES_ARRAY)) = 0 Then or go through items with For Each statements. Here is the code:
Function LINENAMES_ARRAY() As Variant
'returns an array of all items in the main sheet linenames column
LINENAMES_ARRAY = Application.Transpose(MAIN.Range( _
MAIN.Cells(MAIN_HEAD_COUNT + 1, MAIN_LINENAMES_COLUMN), _
MAIN.Cells(LINENAMES_COUNT + 1, MAIN_LINENAMES_COLUMN)))
End Function
I recently stumbled on one of those you-don't-see-it-till-you-see-it problems while using this workbook for a new project, where if the array happens to be only 1 element, everything fails. Apparently in that case, this returns a single value so Join() will fail For Each __ in LINENAMES_ARRAY will too. Why won't it treat this as a 1x1 array rather than a free value? I have started to mitigate the problem by rewriting functions where this is called, to check whether it is an array, then do some other procedure. Things like:
For j = 1 To LINENAMES_COUNT
LINES_BOX.AddItem lineNames(j)
Next j
is changed to:
If Not IsArray(LINENAMES_ARRAY) Then
myListBox.AddItem CStr(LINENAMES_ARRAY)
Else
For j = 1 To LINENAMES_COUNT
LINES_BOX.AddItem LINENAMES_ARRAY(j)
Next j
End If
However this becomes messy and is adding many extra checks to my code that I would prefer to handle in the LINENAMES_ARRAY function. Is there a way to return a 1x1 array? Or any other workaround?
An array can have a single element if you create it as a single element array and populate it in an array manner.
Option Explicit
Dim MAIN_HEAD_COUNT As Long
Dim LINENAMES_COUNT As Long
Dim MAIN_LINENAMES_COLUMN As Long
Dim MAIN As Worksheet
Sub stuff()
Dim arr As Variant
Set MAIN = Worksheets("Sheet1")
MAIN_LINENAMES_COLUMN = 2
MAIN_HEAD_COUNT = 2
LINENAMES_COUNT = 2
arr = LINENAMES_ARRAY()
Debug.Print IsArray(arr)
Debug.Print LBound(arr) & ":" & UBound(arr)
End Sub
Function LINENAMES_ARRAY() As Variant
Dim a As Long, tmp() As Variant
ReDim tmp(0 To LINENAMES_COUNT - MAIN_HEAD_COUNT)
For a = 0 To LINENAMES_COUNT - MAIN_HEAD_COUNT
tmp(a) = MAIN.Range(MAIN.Cells(MAIN_HEAD_COUNT + 1, MAIN_LINENAMES_COLUMN), _
MAIN.Cells(LINENAMES_COUNT + 1, MAIN_LINENAMES_COLUMN)).Cells(a).Value2
Next a
'returns an array of all items in the main sheet linenames column
LINENAMES_ARRAY = tmp
End Function
Results from the VBE's Immediate window:
True
0:0
I have been trying to get this VBA script to work to automate a task, but I cannot get it to work.
Basically, I have a big task list in excel with multiple columns and over 1000 Rows. It contains the task, who it is assigned to, and if it is open or closed.
In column H is who it assigned to and column N is whether the task is opened or closed.
I am trying to search by last name and if it is OPEN to add one to the counter. The end goal is to get a total count of how many open tasks a person has. Also, some of the cells in column N (task status) has extra text like comments, etc. I am sure that a InStr Function to search for the one word within the Cell would work better, but I cannot figure it out...
here is my code
Sub statuscount()
Dim tasksheet As Worksheet
Dim simons_count As Integer
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" And tasksheet.Cells(x, 14) = "OPEN" Then
simons_count = simons_count + 1
End If
Next x
tasksheet.Range("$O$5").Value = simons_count
End Sub
Thanks for the help!
Using If/And gets tricky in VBA, you're better off nesting two if statements:
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" Then
If InStr(tasksheet.Cells(x, 14).Value, "OPEN") > 0 Then
simons_count = simons_count + 1
End If
End If
Next x
This is a more general function. Insert a module and past the below code in it. Than you can use the function just like any other Excel built-in function
Function LastNamecounter(lastName As String, status As String) As Long
LastNamecounter = 0
Dim tasksheet As Worksheet
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr
If InStr(tasksheet.Cells(i, 8).Value, lastName) <> 0 And InStr(tasksheet.Cells(i, 14).Value, status) <> 0 Then
LastNamecounter = LastNamecounter + 1
End If
Next i
End Function
I am writing a subroutine in VBA to cycle through all the listed job numbers in a multi-tab time sheet and create a list of all job numbers that have been used (so it takes the original list (with possibly multiple job number occurrences) and creates a list with only one occurrence of each job number. The job numbers on each sheet are found in range("A8:A30"). The code below seems to work for the first several job names on the sample that I'm testing, but then seems to stop filtering. A8:A21 of the first sheet is:
14GCI393
14GCI393
13GCI373
13GCI373
13GCI388
13GCI367:2
14GCI408
14GCI408
13GCI373
13GCI388
14GCI415
14GCI415
00GCI000
And the code is:
Sub listusedjobs()
Dim usedjobs() As String
Dim nextjob As String
Dim i, m, n, lastsheetindexnumber As Integer
Application.ScreenUpdating = False
lastsheetindexnumber = ThisWorkbook.Sheets.Count
m = 0
ReDim usedjobs(m)
usedjobs(m) = "initialize"
For i = 1 To lastsheetindexnumber
Sheets(i).Activate
For n = 8 To 30
nextjob = Range("A" & n).Value
If Not IsInArray(nextjob, usedjobs) Then 'determine if nextjob is already in usedjobs()
ReDim usedjobs(m)
usedjobs(m) = nextjob 'Add each unique job to array "usedjobs"
Sheets(lastsheetindexnumber).Cells(m + 40, 1).Value = nextjob 'Print job name that was just added
m = m + 1
End If
Next n
Next i
Application.ScreenUpdating = True
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound, , vbTextCompare)) > -1)
End Function
Any help figuring out what is going wrong will be much appreciated! The current output I get for this code is below and contains multiple doubles.
14GCI393
13GCI373
13GCI388
13GCI367:2
14GCI408
13GCI373
13GCI388
14GCI415
00GCI000
I think that your problem may be not using ReDim Preserve inside your If Not
I have a simple task that i need to automate.
I get a email in a very specific format from another application based on a trigger.
What i want is that out look "reads" the data in that email and compare two cells. if one cell is greater than the other, then i want the email forwarded to a specified address otherwise delete the email.
the folowing vba code was attempted, but gives a run time error. please guide
Sub GetLines()
Dim msg As Outlook.mailItem
Dim rows As Variant
Dim numberofColumns As Long
Dim numberofRows As Long
Dim headerValues As Variant
Dim headerRow() As String
Dim data() As String
Dim i As Long, j As Long
' get currently selected email
Set msg = ActiveExplorer.Selection.item(1)
' tokenize each line of the email
rows = Split(msg.Body, vbCrLf)
' calculate array size
numberofColumns = Len(rows(0)) - Len(Replace(rows(0), Chr(9), ""))
numberofRows = UBound(rows) + 1
' put header row into array
ReDim headerRow(1 To numberofColumns)
headerValues = Split(rows(0), Chr(9))
For i = 1 To numberofColumns
headerRow(i) = Trim$(headerValues(i - 1))
Next i
' calculate data array size
numberofRows = numberofRows - 1
' put data into array
ReDim data(1 To numberofRows, 1 To numberofColumns)
For i = 1 To numberofRows
For j = 1 To numberofColumns
data(i, j) = Trim$(Split(rows(i), Chr(9))(j - 1))
Next j
Next i
End Sub
Your code makes too many unnecessary assumptions about the data and will give errors most of the time. Firstly you need to use F8 to step through the code to isolate the error in a particular line.
I suggest you change
Dim data() As String
to
Dim data As Variant
data = Array()
I'm not an expert in how VBA manages memory but I know that I get a lot less grief when I make things variants.
You are most likely to have a problem here:
For i = 1 To numberofRows
For j = 1 To numberofColumns
data(i, j) = Trim$(Split(rows(i), Chr(9))(j - 1))
Next j
Next i
What if not every row is perfectly formed?
Instead, try this:
For i = 1 To numberofRows
For j = 1 To Ubound(Split(rows(i), Chr(9))) + 1
data(i, j) = Trim$(Split(rows(i), Chr(9))(j - 1))
Next j
Next i
This allows your code to "survive" a blank line or some other error in the data.