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
Related
I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function
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
Situation
I have a UDF that works with a range that it is passed that is of variable height and 2 columns wide. The first row will contain text in column 1 and an empty column2. The remainder of column 1 will contain unsorted text with an associated value in the same row in column 2. I need to sort the data such that if some text in column 1 also appears in some other text in column.
Problem
My VBA skills are all self taught and mimimal at best. I remember a few decades ago in university we did bubble sorts and played with pointers, but I no longer remember how we achieved any of that. I do well reading code but creating is another story.
Objective
I need to generate a sort procedure that will produce unique text towards the bottom of the list. I'll try wording this another way. If text in column1 can be found within other text in column, that the original text need to be placed below the other text it can be found in along with its associated data in column 2. The text is case sensitive. Its not an ascending or descending sort.
I am not sure if its a restriction of the UDF or not, but the list does not need to be written back to excel, it just needs to be available for use in my UDF.
What I have
Public Function myFunk(rng As Range) As Variant
Dim x As Integer
Dim Datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
Datarange = rng.Value
'insert something around here to get the list "rng or Datarange" sorted
'maybe up or down a line of code depending on how its being done.
Equation = Datarange(1, 1)
For x = 2 To UBound(Datarange, 1)
VariablesLength = Len(Datarange(x, 1)) - 1
Variable = Left$(Datarange(x, 1), VariablesLength)
Equation = Replace$(Equation, Variable, Datarange(x, 2))
Next x
myFunk = rng.Worksheet.Evaluate(Equation)
End Function
Example Data
Any help with this would be much appreciated. In that last example I should point out that the "=" is not part of the sort. I have a routine that strips that off the end of the string.
So in order to achieve what I was looking for I added a SWAP procedure and changed my code to look like this.
Public Function MyFunk(rng As Range) As Variant
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
'convert the selected range into an array
datarange = rng.Value
'verify selected range is of right shape/size
If UBound(datarange, 1) < 3 Or UBound(datarange, 2) <> 2 Then
MyFunk = CVErr(xlErrNA)
Exit Function
End If
'strip the equal sign off the end if its there
For x = 2 To UBound(datarange, 1)
If Right$(datarange(x, 1), 1) = "=" Then
datarange(x, 1) = Left$(datarange(x, 1), Len(datarange(x, 1)) - 1)
End If
Next x
'sort the array so that a variable does not get substituted into another variable
'do a top down swap and repeat? Could have sorted by length apparently.
For x = 2 To UBound(datarange, 1) - 1
For y = x + 1 To UBound(datarange, 1)
If InStr(1, datarange(y, 1), datarange(x, 1)) <> 0 Then
For z = LBound(datarange, 2) To UBound(datarange, 2)
Call swap(datarange(y, z), datarange(x, z))
Next z
y = UBound(datarange, 1)
x = x - 1
End If
Next y
Next x
'Set the Equation
Equation = datarange(1, 1)
'Replace the variables in the equation with values
For x = 2 To UBound(datarange, 1)
Equation = Replace$(Equation, datarange(x, 1), datarange(x, 2))
Next x
'rest of function here
End Function
Public Sub swap(A As Variant, B As Variant)
Dim Temp As Variant
Temp = A
A = B
B = Temp
End Sub
I sorted by checking to see if text would substitute into other text in the list. Byron Wall made a good point that I could have sorted based on text length. Since I had completed this before I saw the suggestion it did not get implemented though I think it may have been a simpler approach.
I am not familiar with using macro's, but I think that what I would like excel to perform is best handled with a macro. So I can use all the input you may have!
I have these headers;
ID Tag Pen Sex Weight Class Inside range
With 450 rows of data. Based on the distribution of the weight data, I have in two other columns (class and number) the number of rows I want to select within each class. The selected rows must have the value "Yes" in the column "Inside range".
I want to randomly select the rows, based on the number needed for each class, and copy these rows to a new sheet. It sums up to 30 rows in the new sheet.
I hope you have a suggestion how to complete this action!
can you try the following, you will need to add a reference to Microsoft Scripting Runtime library:
Const rowCount = 450
Public Sub copyRows()
Dim i As Integer
Dim j As Integer
Dim classes As Scripting.Dictionary
Dim source As Worksheet
Dim colNumber As Integer
Dim colClassName as Integer
Dim colInsideRange As Integer
Dim allSelected As Boolean
Dim randomRow as Integer
Dim sumRemaining as Integer
allSelected = False
Set source = Worksheets("YourWorksheetName")
colClassName = 6 'this is the column number where class names are entered. I am assuming 6
colNumber = 7 'this is the column number where number of rows to be selected are entered. I am assuming 7
colInsideRange = 8 'this is the column number where "Inside Range" values are entered. I am assuming 9
For i = 2 to rowCount + 1 'assuming you have a header row
classes(CStr(source.Cells(i, colClassName))) = CInt(source.cells(i, colNumber)
Next i
Do until allSelected
Randomize
randomRow = Int ((Rnd * 450) + 2) 'assuming you have a header row, + 1 if you don't
If classes(CStr(source.Cells(randomRow, colClassName))) = 0 Then
With classes
sumRemaining = 0
For j = 1 to .Count - 1
sumRemaining = sumRemaining + .Items(j)
If sumRemaining > 0 Then Exit For
Next j
allSelected = (sumRemaining = 0)
End With
Else
source.Cells(randomRow, colInsideRange) = "Yes"
classes(CStr(source.Cells(randomRow, colClassName))) = classes(CStr(source.Cells(randomRow, colClassName))) - 1
End If
Loop
'Enter your code to copy rows with "Inside Range" = "Yes"
End Sub
Sorry if there are some errors or typos, I wrote from my mobile phone.
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.