I have document containing all the questions in a certain test along with a table of its statistics. I'm attempting to transfer data between these tables, specifically inserting the percentage of people who chose a certain multiple choice answer into a box beside the actual answer in the question.
I've attached a screenshot of what the question table and statistic table look like 1, there are 25 question tables in my document and one statistics table that goes on for 25 question.
Below is my code. The portion under the Else condition is functional but I can't seem to get my first If Condition and loop to collect the data from the statistics table into the array I set up. Hopefully someone can provide insight into why the first section is not working.
Sub Insert_Statistics()
Dim QTable As Table
Dim RowCount As Integer
Dim StringValue As String
Dim i As Integer
Dim j As Integer
Dim A(35) As String
Dim B(35) As String
Dim C(35) As String
Dim D(35) As String
For Each QTable In ActiveDocument.Tables
If RowCount > 14 Then
Do While i < 25
A(i + 1) = QTable.Rows(4 * i + 4).Cells(4).Range.Text
B(i + 1) = QTable.Rows(4 * i + 4).Cells(5).Range.Text
C(i + 1) = QTable.Rows(4 * i + 4).Cells(6).Range.Text
D(i + 1) = QTable.Rows(4 * i + 4).Cells(7).Range.Text
i = i + 1
Loop
Else
QTable.Rows(1).Cells(2).Select
StringValue = Selection.Text
j = Val(StringValue)
QTable.Rows(6).Cells(3).Range.Text = A(j)
QTable.Rows(6).Cells(3).Range.ParagraphFormat.Alignment =
Word.WdParagraphAlignment.wdAlignParagraphLeft
QTable.Rows(7).Cells(3).Range.Text = B(j)
QTable.Rows(7).Cells(3).Range.ParagraphFormat.Alignment =
Word.WdParagraphAlignment.wdAlignParagraphLeft
QTable.Rows(8).Cells(3).Range.Text = C(j)
QTable.Rows(8).Cells(3).Range.ParagraphFormat.Alignment =
Word.WdParagraphAlignment.wdAlignParagraphLeft
QTable.Rows(9).Cells(3).Range.Text = D(j)
QTable.Rows(9).Cells(3).Range.ParagraphFormat.Alignment =
Word.WdParagraphAlignment.wdAlignParagraphLeft
QTable.AutoFitBehavior wdAutoFitWindow
End If
Next
End Sub
Related
I am trying to write a VBA code to work within excel which will do the following:
I need to search through a column to find a date, once it is found I need 3 variables in that row to be copied over to another sheet in the same workbook. This is metocean data retrieved from the public domain, so dates are in order.
Below I've written a code which in my opinion SHOULD do the job, but for some reason only returns the first occurrence of the date which is used as input. I need it to copy the remaining days' code as well (ex. copy date corresponding to all the "January2"s in the data set).
Sub DataRetrieve()
Dim MDCount As Long
MDCount = 2
Dim OutputCount As Long
OutputCount = 5
Dim TimespanCount As Integer
TimespanCount = 0
Dim TimespanDAY As Range
Set TimespanDAY = Worksheets("TOOL").Cells((TimespanCount + 9), 5)
Dim HourCount As Integer
HourCount = 0
Dim Timespan As Range
Set Timespan = Worksheets("TOOL").Cells(6, 6)
Dim i As Integer
i = 0
'-------------------------------------------------------------------------------
Do Until Worksheets("DATA").Cells(MDCount, 15) = "END"
If TimespanDAY.Text = DayRead.Text Then
Do Until HourCount = 24
Worksheets("TEMP").Cells(OutputCount, 2) = Worksheets("DATA").Cells(MDCount, 7).Value
Worksheets("TEMP").Cells(OutputCount, 3) = Worksheets("DATA").Cells(MDCount, 8).Value
Worksheets("TEMP").Cells(OutputCount, 4) = Worksheets("DATA").Cells(MDCount, 9).Value
MDCount = MDCount + 1
OutputCount = OutputCount + 1
HourCount = HourCount + 1
Loop
End If
MDCount = MDCount + 1
Set DayRead = Worksheets("DATA").Cells(MDCount, 4)
Set TimespanDAY = Worksheets("TOOL").Cells((TimespanCount + 9), 5)
Loop
End Sub
Ideally, I'd like to expand this (once it works) to then restart the loop and go to the next corresponding date (ex. January3) do the exact same thing, and store in another column on the same sheet where the last data was stored.
I can explain more clearly if necessary. I appreciate any help! This is for a school project so time is of essence.
Andrew
We have an SQL database that exports to excel. Each record in the database is the evaluation of a project. Each project has a project identifier (string). Since a project can be evaluated two times, each project can have two records. The difference between the two records is the id number (number), with the most recent record having a higher id number. The records are exported to excel with each record as a row in the spread sheet. I am trying to write a sub that compares the two project identifiers and deletes the row with the lower id number. I keep getting an object required error for SameP.
Dim Pident1 As String
Dim Pident2 As String
Dim IdNumb1 As Variant
Dim IdNumb2 As Variant
Dim i As Integer
Dim SameP As Integer
i = 2
For i = 2 To 100
Pident1 = ActiveSheet.Cells(i, 2).Text
Pident2 = ActiveSheet.Cells(i + 1, 2).Text
IdNumb1 = ActiveSheet.Cells(i, 1).Value
IdNumb2 = ActiveSheet.Cells(i + 1, 1).Value
Set SameP = StrComp(Pident1, Pident2, CompareMethod.Text)
If SameP = 0 And IdNumb1> Idnumb2 Then Data.Rows(i).EntireRow.Delete
Next i
End Sub
Any help would be greatly appreciated. I'm not a programmer, i just try when I can. Thanks in advance.
You need to change this
SameP = StrComp(Pident1, Pident2, CompareMethod.Text)
to this:
SameP = StrComp(Pident1, Pident2)
The error is this line also
Data.Rows(i).EntireRow.Delete
Change this to
Sheets("Name_of_sheet_here").Rows(i).EntireRow.Delete
Alternatively this would work too
Activeworksheet.Rows(i).EntireRow.Delete
Change this:
Set SameP = StrComp(Pident1, Pident2, CompareMethod.Text)
If SameP = 0 And IdNumb1> Idnumb2 Then Data.Rows(i).EntireRow.Delete
to
SameP = StrComp(Pident1, Pident2, vbTextCompare )
If SameP = 0 And IdNumb1> Idnumb2 Then ActiveSheet.Rows(i).EntireRow.Delete
I am working on a sub which will take data from one table (HeadsTable) and fill it into the appropriate place in another table (AllocatedHeads). The HeadsTable contains headcount data by year. These headcounts need to be split by a number of stakeholders and funding types. The AllocatedHeads table will have a row for each stakeholder and funding type so one entry in the HeadsTable corresponds to multiple in the AllocatedHeads table(up to 30). The headcounts themselves I am filling in with excel formulas, but I want the macro to fill in all of the decriptive data from the heads table.
I have created a HeadsEntry Class which holds all of the field data for an entry from HeadsTable and a HeadsCollection Class which is just a collection of all of the HeadsEntry Objects.
I am happy to show my entire sub, but what is shown here relates to my efforts to fill the table by iterating over the HeadsCollection. The code below is functional, but takes a REALLY long time. Hours. My first attempt also worked and is shown in the comments. It also took hours to run.
Is there a way I can accomplish this task in a more reasonable run time?
Dim AbsRow As Long
If [AllocatedHeads].ListObject.ListRows.Count > 0 Then
'clear table, add one row, get row value
[AllocatedHeads].ListObject.DataBodyRange.Rows.Delete
[AllocatedHeads].ListObject.ListRows.Add
AbsRow = [AllocatedHeads].ListObject.ListRows(1).Range.Row
End If
'dimension field column variables
Dim DescriptionCol As Integer
Dim LMWBSCol As Integer
Dim Org1Col As Integer
Dim Org2Col As Integer
Dim Org3Col As Integer
Dim PALS_OSsplitCol As Integer
Dim ServiceShareRuleCol As Integer
Dim Heads_IDCol As Integer
Dim PALS_OSCol As Integer
Dim ServiceCol As Integer
'assign column values to variables
DescriptionCol = [AllocatedHeads[Description]].Column
LMWBSCol = [AllocatedHeads[LM WBS]].Column
Org1Col = [AllocatedHeads[Org Tier 1]].Column
Org2Col = [AllocatedHeads[Org Tier 2]].Column
Org3Col = [AllocatedHeads[Org Tier 3]].Column
PALS_OSsplitCol = [AllocatedHeads[PALS/O&S Split]].Column
ServiceShareRuleCol = [AllocatedHeads[Service Share Rule]].Column
Heads_IDCol = [AllocatedHeads[Heads_ID]].Column
PALS_OSCol = [AllocatedHeads[PALS/O&S]].Column
ServiceCol = [AllocatedHeads[Service]].Column
' RowNum = 1
For Each Entry In HeadsCollection.Entries
For i = 1 To UBound(Entry.PALSOS)
For j = 1 To UBound(Entry.Service)
' [AllocatedHeads].ListObject.ListRows.Add
' AbsRow = [AllocatedHeads].ListObject.ListRows(RowNum).Range.Row
Cells(AbsRow, DescriptionCol) = Entry.Description
Cells(AbsRow, LMWBSCol) = Entry.LMWBS
Cells(AbsRow, Org1Col) = Entry.Org1
Cells(AbsRow, Org2Col) = Entry.Org2
Cells(AbsRow, Org3Col) = Entry.Org3
Cells(AbsRow, PALS_OSsplitCol) = Entry.PALSOSsplit
Cells(AbsRow, ServiceShareRuleCol) = Entry.ServiceRule
Cells(AbsRow, Heads_IDCol) = Entry.ID
Cells(AbsRow, PALS_OSCol) = Entry.PALSOS(i - 1)
Cells(AbsRow, ServiceCol) = Entry.Service(j - 1)
AbsRow = AbsRow + 1
' Set RowRange = [AllocatedHeads].ListObject.ListRows(RowNum).Range
' Intersect(RowRange, [AllocatedHeads[Description]]) = Entry.Description
' With Intersect(RowRange, [AllocatedHeads[LM WBS]])
' .value = Entry.LMWBS
' .NumberFormat = "#"
' End With
' Intersect(RowRange, [AllocatedHeads[Org Tier 1]]) = Entry.Org1
' Intersect(RowRange, [AllocatedHeads[Org Tier 2]]) = Entry.Org2
' Intersect(RowRange, [AllocatedHeads[Org Tier 3]]) = Entry.Org3
' Intersect(RowRange, [AllocatedHeads[PALS/O&S Split]]) = Entry.PALSOSsplit
' Intersect(RowRange, [AllocatedHeads[Service Share Rule]]) = Entry.ServiceRule
' Intersect(RowRange, [AllocatedHeads[Heads_ID]]) = Entry.ID
' Intersect(RowRange, [AllocatedHeads[PALS/O&S]]) = Entry.PALSOS(i - 1)
' Intersect(RowRange, [AllocatedHeads[Service]]) = Entry.Service(j - 1)
' RowNum = RowNum + 1
Next j
Next i
Next Entry
My solution was to convert to a range, fill in the cells, and convert back to a table. Filling in cells in a range is MUCH quicker than in a table. I also took advantage of the fact that filling in the first cell in a table column turns it into a calculated field. By using formulas in those fields I reduced the number of fields I was storing in my Entry object and the number of cells I needed to fill in. I am sure that there are much faster ways, but this solution brings it down from hours to under a minute, which is good enough for my needs. The code beow doesn't show the entire sub, only the relevant portion.
'determine needed size for Allocated heads table
AllocatedHeadsRowCount = 0
For Each Entry In HeadsCollection.Entries
AllocatedHeadsRowCount = AllocatedHeadsRowCount + (UBound (Entry.PALSOS) * UBound(Entry.Service))
Next Entry
'determine Absolute row (sheet row, instead of listobject row) of first row in table
Dim AbsRow As Long
AbsRow = [AllocatedHeads].ListObject.HeaderRowRange.Row + 1
'delete all table rows
If [AllocatedHeads].ListObject.ListRows.Count > 0 Then
'clear table, add one row, get row value
[AllocatedHeads].ListObject.DataBodyRange.Rows.Delete
End If
'assign number values of header row, first table column, number of column
AllocatedHeadsStartRow = [AllocatedHeads].ListObject.HeaderRowRange.Row
AllocatedHeadsStartColumn = [AllocatedHeads].ListObject.HeaderRowRange.Column
AllocatedNumberofColumns = [AllocatedHeads].ListObject.HeaderRowRange.Columns.Count
'dimension field column variables
Dim Heads_IDCol As Integer
Dim PALS_OSCol As Integer
Dim ServiceCol As Integer
'assign column values to variables
Heads_IDCol = [AllocatedHeads[Heads_ID]].Column
PALS_OSCol = [AllocatedHeads[PALS/O&S]].Column
ServiceCol = [AllocatedHeads[Service]].Column
'convert table to range because filling cells in a range is MUCH faster than in a table
[AllocatedHeads].ListObject.Unlist
'fill ID, PALS/O&S, and Service columns
For Each Entry In HeadsCollection.Entries
For i = 1 To UBound(Entry.PALSOS)
For j = 1 To UBound(Entry.Service)
Cells(AbsRow, Heads_IDCol) = Entry.ID
Cells(AbsRow, PALS_OSCol) = Entry.PALSOS(i - 1)
Cells(AbsRow, ServiceCol) = Entry.Service(j - 1)
AbsRow = AbsRow + 1
Next j
Next i
Next Entry
'convert back to table
With Sheets("Allocated Heads").ListObjects.Add(xlSrcRange, Range(Cells(AllocatedHeadsStartRow, AllocatedHeadsStartColumn), Cells(AllocatedHeadsStartRow + AllocatedHeadsRowCount, AllocatedHeadsStartColumn + AllocatedNumberofColumns - 1)), , xlYes)
.Name = "AllocatedHeads"
.TableStyle = "TableStyleMedium7"
End With
'add formulas to the first cell in columns for which the data is the same as in the heads table.
'This creates a calculated column and will fill down
[AllocatedHeads].ListObject.ListColumns("Service Share Rule").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Service Share Rule]:[Service Share Rule]])"
[AllocatedHeads].ListObject.ListColumns("PALS/O&S Split").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[PALS/O&S Split]:[PALS/O&S Split]])"
[AllocatedHeads].ListObject.ListColumns("Org Tier 1").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 1]:[Org Tier 1]])"
[AllocatedHeads].ListObject.ListColumns("Org Tier 2").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 2]:[Org Tier 2]])"
[AllocatedHeads].ListObject.ListColumns("Org Tier 3").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 3]:[Org Tier 3]])"
[AllocatedHeads].ListObject.ListColumns("LM WBS").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[LM WBS]:[LM WBS]])"
[AllocatedHeads].ListObject.ListColumns("Description").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Description]:[Description]])"
[AllocatedHeads].ListObject.ListColumns("2009").DataBodyRange = "=LOOKUP(AllocatedHeads[#[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[2009])*SUMPRODUCT((AllocatedHeads[#[PALS/O&S Split]:[PALS/O&S Split]] = SplitTable[[Split Name]:[Split Name]])*(AllocatedHeads[#[PALS/O&S]:[PALS/O&S]] = SplitTable[[PALS/O&S]:[PALS/O&S]])*SplitTable[2009])*SUMPRODUCT((AllocatedHeads[#[Service Share Rule]:[Service Share Rule]]=SplitTable[[Split Name]:[Split Name]])*(AllocatedHeads[#[Service]:[Service]]=SplitTable[[Service]:[Service]])*SplitTable[2009])"
'Fill years columns by first drragging across(to have appropriate column references),
'then copy pasting in place in order to create calculated columns
Dim FirstCell As Range
Dim FillRange As Range
Set FirstCell = Intersect([AllocatedHeads].ListObject.DataBodyRange.Rows(1), [AllocatedHeads[2009]])
Set FillRange = Range(FirstCell.Address, Cells(FirstCell.Row, [AllocatedHeads].ListObject.Range.SpecialCells(xlLastCell).Column))
FirstCell.AutoFill FillRange, xlFillDefault
FillRange.Copy
FirstCell.PasteSpecial xlPasteFormulas
'create calculated column in Total column
[AllocatedHeads].ListObject.ListColumns("Total").DataBodyRange = "=SUM(" & FirstCell.Address(False, False) & ":" & Cells(FirstCell.Row, [AllocatedHeads].ListObject.Range.SpecialCells(xlLastCell).Column).Address(False, False) & ")"
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
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.