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.
Related
All, I'm trying to do a quasi-montecarlo analysis, and have had success storing values from single cells into an array during every draw, and then pasting later. When I'm trying to store an entire row into an array, though, the script doesn't seem to work. Hoping someone can shed some insight, thank you for your help! This issue is somewhere in the curvearray, which is copying 10 cells in the same row on each draw.
Dim randa As Double
Dim stdeva As Double
Dim looprun As Double
Dim arrayone() As Variant
Dim arraytwo() As Variant
Dim curvearray() As Variant
ReDim arrayone(1 To 1)
ReDim arraytwo(1 To 1)
ReDim curvarray(1 To 10)
stdeva = 1
a = Range("baseline").Value
For looprun = 1 To 100
randa = Rnd
Range("baseline").Value = WorksheetFunction.NormInv(randa, a, stdeva)
Application.Calculate
arrayone(UBound(arrayone)) = Range("net").Value
ReDim Preserve arrayone(1 To UBound(arrayone) + 1)
arraytwo(UBound(arraytwo)) = Range("multi").Value
ReDim Preserve arraytwo(1 To UBound(arraytwo) + 1)
curvearray(UBound(curvearray)) = Range("curve").Value
ReDim Preserve curvearray(1 To UBound(curvearray) + 1)
Next looprun
Range("onepaste").Resize(UBound(arrayone)) = Application.Transpose(arrayone)
Range("twopaste").Resize(UBound(arraytwo)) = Application.Transpose(arraytwo)
Range("curvepast").Resize(UBound(curvearray)) = Application.Transpose(curvearray)
End Sub
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 am trying to calculate the count of Unique values based on a condition.
For example,
For a value in column B, I am trying to count the Unique values in Column C through VBA.
I know how to do it using Excel formula -
=SUMPRODUCT((B2:B12<>"")*(A2:A12=32)/COUNTIF(B2:B12,B2:B12))
that value for 32 is dynamic - Programmatically I am calling them inside my vba code as Name
This is my code :
Application.WorksheetFunction.SumProduct((rng <> "") * (rng2 = Name) / CountIfs(rng, rng))
This is the sample data with the requirement
Alternatively, I Concatenated both the columns for keeping it simple and hoping to identify the Unique values which starts with name* method.
I don't know where I am going wrong. Kindly share your thoughts.
You may try something like this...
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
Then you can use it like below...
=GetUniqueCount($A$2:$B$10,C2)
Where A2:B10 is the data range and C2 is the name criteria.
I'd put the values into an array, create a temporary 2nd array and only add values to this array if they are not already present, and then replace the original array. Then it's just a simple matter to sum the unique values:
Sub Unique
dim arr(10) as variant, x as variant
dim arr2() as variant
for x = 1 to 10 ' or whatever
arr(x) = cells(x, 1) ' or whatever
next x
arr2 = UniqueValuesArray(arr)
' now write some code to count the unique values, you get the idea
End Sub
Function UniqueValuesArray(arr As Variant) As Variant()
Dim currentRow, arrpos As Long
Dim uniqueArray() As Variant
Dim x As Long
arrpos = 0
ReDim uniqueArray(arrpos)
For x = 0 To UBound(arr)
If UBound(Filter(uniqueArray, arr(x))) = -1 Then
ReDim Preserve uniqueArray(arrpos)
uniqueArray(arrpos) = arr(x)
arrpos = arrpos + 1
End If
Next x
UniqueValuesArray = uniqueArray
End Function
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.
I am pulling out values from a variable number of sheets within excel (fifth to third from last), each of which contains a variable number of "entries". E.G. "Entry 1" has values I want in columns F and H. "Entry 2" has values I want in columns K and M, etc. (These are also referred to as "quotes" in the comments for the code).
I'm using a For loop within a For loop to accomplish this. The issue I'm having is that each recursion of the "parent" for loop is over-writing the entries created in the previous recursion. My code illustrates:
Sub ListSheets()
' Creating an integer that specifies the size of the arrays of column entries
' and thus the maximum number of quotes.
Dim array_size As Integer
'Defining Arrays that will be used to select quantities of different quotes
'(e.g. Class)
'Region, Date and Price all have the same column entries, meaning only one array is
'required.
Dim Class_Cols_Array() As Integer
Dim RDP_Cols_Array() As Integer
'Resizing these arrays. This resize sets the maximum number of quotes per sheet to
'1000.
array_size = 1000
ReDim Class_Cols_Array(1 To array_size, 1 To 1)
ReDim RDP_Cols_Array(1 To array_size, 1 To 1)
'Setting the first entries as the corresponding column indexes of H and F
'respectively.
Class_Cols_Array(1, 1) = 8
RDP_Cols_Array(1, 1) = 6
' Filling both arrays with column indexes of quotes. In both cases the row number is
'the same for each quote and thus
' does not need to be specified for each entry.
For intLoop = 2 To 1000
Class_Cols_Array(intLoop, 1) = Class_Cols_Array(intLoop - 1, 1) + 5
RDP_Cols_Array(intLoop, 1) = RDP_Cols_Array(intLoop - 1, 1) + 5
Next
'Defining an array which will contain the number of entries/quotes (as defined by
' the user) for each sheet/manufacturer.
Dim Num_of_Entries() As Integer
' Resizing this array to match the number of manufacturers (sheets therein) within
'the workbook.
ReDim Num_of_Entries(1 To Worksheets.Count - 6, 1 To 1)
'Defining arrays that will contain will be populated with quote quantities (e.g.
'Class), pulled from cells.
Dim Class_Array() As String
Dim Region_Array() As String
Dim Date_Array() As String
Dim Price_Array() As String
Dim Manufacturer_Array() As String
'Here number of entries for each manufacturer (sheet) are pulled out, with this
'value being entered into the appropriate cell(B5)
'by the user.
Dim i As Integer
For i = 5 To Worksheets.Count - 2
j = i - 4
Num_of_Entries(j, 1) = ThisWorkbook.Worksheets(i).Cells(5, 2)
Next
'Creating an integer that is the total number of entries (that for all sheets
'combined).
Dim total_entries As Integer
total_entries = WorksheetFunction.Sum(Num_of_Entries)
'Setting the size of each quantity-containing array to match the total number of
'entries.
ReDim Class_Array(1 To total_entries, 1 To 1)
ReDim Region_Array(1 To total_entries, 1 To 1)
ReDim Date_Array(1 To total_entries, 1 To 1)
ReDim Price_Array(1 To total_entries, 1 To 1)
ReDim Manufacturer_Array(1 To total_entries, 1 To 1)
'Creating a variable for the numbers of entries for a specific sheet.
Dim entries_for_sheet As Integer
'Creating a variable for the sheet number for a specific sheet (e.g. "Acciona_Fake
'is the 5th sheet).
Dim sheet_number As Integer
'Looping over the sheets (only fifth to third from last sheets are of interest).
For sheet_number = 5 To Worksheets.Count - 2
'Creating an iterating value that starts at 1 in order to match sheets to their
'number of entries.
j = sheet_number - 4
entries_for_sheet = Num_of_Entries(j, 1)
'Looping over the entries for each sheet, extracting quote quantities and adding
'to their respective arrays.
For i = 1 To entries_for_sheet
Class_Array(i, 1) = ThisWorkbook.Worksheets(sheet_number).Cells(6,
Class_Cols_Array(i, 1))
Region_Array(i, 1) = ThisWorkbook.Worksheets(sheet_number).Cells(6,
RDP_Cols_Array(i, 1))
Date_Array(i, 1) = ThisWorkbook.Worksheets(sheet_number).Cells(8,
RDP_Cols_Array(i, 1))
Price_Array(i, 1) = ThisWorkbook.Worksheets(sheet_number).Cells(41,
RDP_Cols_Array(i, 1))
Manufacturer_Array(i, 1) = ThisWorkbook.Worksheets(sheet_number).Name
Next
Next
'Exporting all arrays.
Sheets("vba_deposit").Range("A1").Resize(UBound(Class_Array)).Value = Class_Array
Sheets("vba_deposit").Range("B1").Resize(UBound(Region_Array)).Value = Region_Array
Sheets("vba_deposit").Range("C1").Resize(UBound(Date_Array)).Value = Date_Array
Sheets("vba_deposit").Range("D1").Resize(UBound(Price_Array)).Value = Price_Array
Sheets("vba_deposit").Range("D1").Resize(UBound(Manufacturer_Array)).Value =
Manufacturer_Array
End Sub
Looking at the for loop within a for loop at the bottom, I need to find a way to keep the iteration of the RHS of the equation(s). E.G. I need the i value to be the same for,
ThisWorkbook.Worksheets(sheet_number).Cells(6, Class_Cols_Array(i, 1))
whereas I need the i on the LHS of the equation to also increase with each run of the "parent" for loop. I.E. I need the i to be the "number of entries thus far" + i for
ThisWorkbook.Worksheets(sheet_number).Cells(6, Class_Cols_Array(i, 1))
I can't figure out a way to do this. Is there perhaps a way to append an array rather than assigning values to individual elements? (This sounds really simple but I've searched and not been able to find a genuine append method, only loops of assigning to elements).
Many thanks in advance.
Compiled but not tested:
Sub ListSheets()
Dim intLoop As Long, i As Long, total_entries As Long
Dim sht As Worksheet, sheet_number As Long
Dim entries_for_sheet As Long
Dim classCol As Long, RDPCol As Long
Dim entry_num As Long
Dim Data_Array() As String
total_entries = 0
entry_num = 0
For sheet_number = 5 To Worksheets.Count - 2
Set sht = ThisWorkbook.Worksheets(sheet_number)
entries_for_sheet = sht.Cells(5, 2).Value
total_entries = total_entries + entries_for_sheet
'can only use redim Preserve on the last dimension...
ReDim Preserve Data_Array(1 To 5, 1 To total_entries)
classCol = 8
RDPCol = 6
For i = 1 To entries_for_sheet
entry_num = entry_num + 1
Data_Array(1, entry_num) = sht.Cells(6, classCol)
Data_Array(2, entry_num) = sht.Cells(6, RDPCol) ' 6?
Data_Array(3, entry_num) = sht.Cells(8, RDPCol)
Data_Array(4, entry_num) = sht.Cells(41, RDPCol)
Data_Array(5, entry_num) = sht.Name
classCol = classCol + 5
RDPCol = RDPCol + 5
Next
Next
Sheets("vba_deposit").Range("A1").Resize(UBound(Data_Array, 2), _
UBound(Data_Array, 1)).Value = Application.Transpose(Data_Array)
End Sub