Related
Previous Record and Next Record sub routine is not working. I marked with 1 and 2. These two navigation bars (1&2) works on the what is entered on WaypointId.
Say for example, if I say waypoint id=1235, then next record should appear in a data entry form. My vba code is first search the row number of waypoint id in observation sheet and then I decrease the row number by 1 for displaying previous record and increase the row number by 1 for next record. Depends on the functionality it shows data in the Data Entry Form.
My VBA code is not working for those two things. Attach workbook with name Problem-1.xlsm See Navigation Control Module.
Sub FindRecord(WyPt)
Dim Value As String
WyPtRow = 0
ReadRow = 2
Value = Cells(ReadRow, 2)
While Value <> ""
If WyPt = Value Then
WyPtRow = ReadRow
Exit Sub
End If
ReadRow = ReadRow + 1
Value = Cells(ReadRow, 2)
Wend
End Sub
Sub ViewPreviousRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
Dim WyPt As String
WyPt = Trim(DEFrm.Cells(6, 2))
Call FindRecord(WyPt)
LastRow = WyPtRow - 1
With DEFrm
.Cells(6, 2).Value = ObsData.Cells(LastRow, 2).Value 'WaypointID
.Cells(6, 4).Value = ObsData.Cells(LastRow, 3).Value 'ObsType
.Cells(8, 2).Value = ObsData.Cells(LastRow, 4).Value 'Date
.Cells(8, 4).Value = ObsData.Cells(LastRow, 5).Value 'LoggedBy
End With
End Sub
Sub ViewNextRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
Dim WyPt As String
WyPt = Trim(DEFrm.Cells(6, 2))
Call FindRecord(WyPt)
LastRow = WyPtRow + 1
With DEFrm
.Cells(6, 2).Value = ObsData.Cells(LastRow, 2).Value 'WaypointID
.Cells(6, 4).Value = ObsData.Cells(LastRow, 3).Value 'ObsType
.Cells(35, 10).Value = ObsData.Cells(LastRow, 115) 'Photo4Desc
End With
End Sub
This is the most important procedure in your project.
Sub DisplayRecord(ByVal Rs As Long)
' 235
Dim Arr As Variant ' Data from row Rs in database
Dim Target() As String ' Dashboard addresses matching Arr
Dim i As Long ' loop counter: Arr(Index)
' cell addresses are aligned with column numbers in database (-2)
Arr = "B6,D6,B8,D8,G6,H6,G7,H7,G8,H8,B11,C11,D11,E11,F11,G11,H11,I11"
Arr = Arr & ",B14,C14,D14,E14,F14,G14,B17,C17,D17,E17,F17,G17"
Arr = Arr & ",I14,J14,I15,J15,I16,J16,I17,J17,B20,C20,D20,E20,F20,G20"
Arr = Arr & ",B23,C23,D23,E23,F23"
Arr = Arr & ",I20,J20,K20,I21,J21,K21,I2,J22,K22,I23,J23,K23"
Arr = Arr & ",B26,C26,D26,E26,F26,G26,H26,I26,J26,K26"
Arr = Arr & ",B27,C27,D27,E27,F27,G27,H27,I27,J27,K27"
Arr = Arr & ",B28,C28,D28,E28,F28,G28,H28,I28,J28,K28"
Arr = Arr & ",B29,C29,D29,E29,F29,G29,H29,I29,J29,K29"
Arr = Arr & ",B32,H32,I32,J32,H33,I33,J33,H34,I34,J34,H35,I35,J35"
Target = Split(Arr, ",")
With Sheets("Observations")
Arr = .Range(.Cells(Rs, 1), .Cells(Rs, 115)).Value
End With
Application.ScreenUpdating = False ' speed up execution
For i = 2 To UBound(Arr, 2) ' skip first database column
Sheets("DataEntryForm").Range(Target(i - 2)).Value = Arr(1, i)
Next i
Application.ScreenUpdating = True
End Sub
It displays the data of the row Rs given to it as an argument. You already have a function that finds the row number needed by the above procedure. Below please find an improvement.
Function RecordRow(ByVal WyPt As String) As Long
' 235
' return the row number where WyP was found or 0
Dim Fnd As Range
With Worksheets("Observations")
Set Fnd = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
Set Fnd = Fnd.Find(WyPt, , LookIn:=xlValues, lookat:=xlWhole)
If Not Fnd Is Nothing Then
RecordRow = Fnd.Row
End If
End With
End Function
The deal is simple: you give the Waypoint ID and receive the row number where it was found. If it isn't found the function returns 0, and that is how you avoid crashes.
With these two procedures in place you can easily call up the first and the last records.
Sub ViewFirstRecord()
' 235
DisplayRecord 2
End Sub
Sub ViewLastRecord()
' 235
With Worksheets("Observations")
DisplayRecord .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Sub
The next and previous records are just a matter of finding the row number and displaying its data.
Sub ViewNextRecord()
' 235
Dim Rs As Long ' data source row
Rs = RecordRow(Trim(Cells(6, 2).Value)) + 1
If Rs > 1 Then
With Worksheets("Observations")
If Rs <= .Cells(.Rows.Count, "A").End(xlUp).Row Then
DisplayRecord Rs
Else
MsgBox "No more records to show.", vbInformation, "Last record"
End If
End With
End If
End Sub
Sub ViewPreviousRecord()
' 235
Dim Rs As Long ' data source row
Rs = RecordRow(Trim(Cells(6, 2).Value)) - 1
If Rs > 1 Then
DisplayRecord Rs
Else
MsgBox "No more records to show.", vbInformation, "First record"
End If
End Sub
If that's the whole code, you may be finding a problem with scope. It seems ViewPreviousRecord() is not able to see WyPtRow.
You can try adding
dim WyPtRow
Before the Sub FindRecord(WyPt) definition.
Another implementation would be changing the Sub for a function, and returning the WyPtRow value.
I am trying to compare values in two lists. I want my code to compare a value in the first list and check all the entries in the second list. If there is a match then the code will print true next to the value in the first list and if not it will print false.
The problem I am having is that my code only compares values that are in the same row.
The code runs and I have tried it on a two smaller lists to make sure the data types are to same and there aren't any extra spaces or commas in the lists that would lead to a "False" output. I have also tried changing the order of the for and if statements but this doesn't work either.
Sub findvalues()
For i = 2 To 16
For j = 2 To 16
If Cells(i, 3).Value = Cells(i, 1).Value Then
Cells(i, 4).Value = "TRUE"
ElseIf Cells(i, 3).Value = Cells(j + 1, 1).Value Then
Cells(i, 4).Value = "TRUE"
Else
Cells(i, 4).Value = "FALSE"
End If
Next j
Next i
End Sub
Here are the two lists I am testing the code on
Slight mods to your code based on the data you provided in columns 1 & 3. As always, things could be improved but this should get you going ...
Sub findvalues()
Dim i As Long, j As Long, bResult As Boolean
For i = 2 To 16
strValueToLookFor = Cells(i, 1)
For j = 2 To 16
bResult = False
If strValueToLookFor = Cells(j, 3).Value Then
bResult = True
Exit For
End If
Next j
Cells(i, 6).Value = bResult
Next i
End Sub
... you may just need to flick the columns over so the first list searches on the second list or vice versa.
I don't see any need for VBA - formulas are the way to go - but to avoid two loops one could do this:
Sub findvalues()
Dim i As Long
For i = 2 To 130
Cells(i, 4).Value = IsNumeric(Application.Match(Cells(i, 1).Value, Range("C2:C130"), 0))
Next i
End Sub
Update: this does not cater for multiple matches.
There are many was to achieve that. one of them is by using IF & COUNTIF
Formula
=IF(COUNTIF($E$2:$E$6,A2)>0,"TRUE","FALSE")
Results:
VBA CODE
Option Explicit
Sub findvalues()
Dim i As Long
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1") 'Change if needed
Set rng = .Range("A2:A130") 'set rng to includes values from column A, rows 2:130
For i = 2 To 130 'Loop from row 2 to 130
'Check if the values in column C includes in the rng
If Application.WorksheetFunction.CountIf(rng, .Range("C" & i).Value) > 0 Then
.Range("D" & i).Value = "TRUE"
Else
.Range("D" & i).Value = "FALSE"
End If
Next i
End With
End Sub
VBA code to reconcile two lists.
Sub Reconciliation()
Dim endRow As Long
Dim ICount As Long
Dim Match1() As Variant
Dim Match2() As Variant
Dim ws As Worksheet
Set ws = Worksheets("Recon")
ICount = 0
endRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
endRow1 = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
Match1 = Sheet1.Range("b2:b" & endRow)
Match2 = Sheet1.Range("K2:K" & endRow1)
For i = LBound(Match1) To UBound(Match1)
For j = LBound(Match2) To UBound(Match2)
If Match1(i, 1) = Match2(j, 1) Then
ICount = ICount + 1
Sheet1.Range("C" & i + 1).Value = ICount
Sheet1.Range("L" & j + 1).Value = ICount
Else
End If
Next j
Next i
End Sub
I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.
I want to refer a column by its header name.
Currently column is 4th one and header name is "Preference".
And the column consists of "Yes" or "No"
5th column header is "Reason"
And it is filled only when "Preference" column is "No"
My code is
Private Sub CommandButton1_Click()
Dim i As Integer
Dim MyWorksheetLastRow As Byte
Dim MyWorksheetLastColumn As Byte
MyWorksheetLastRow = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
MyWorksheetLastColumn = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets(1).Cells(1, MyWorksheetLastColumn + 1).Value = "Result"
For i = 2 To MyWorksheetLastRow
If Cells(i, 4).Value = "Yes" Then
Cells(i, MyWorksheetLastColumn + 1).Value = Cells(i, 4).Value
Else: Cells(i, MyWorksheetLastColumn + 1).Value = Cells(i, 5).Value
End If
Next i
End Sub
What I want is instead of Cells(i,4) , I want to call the it by column header example: Cells(i,"Preference").
Because I won't the column number of "Preference" in prior. And I use excel vba because I have to deal 20-30 similar files.
Further to my comments, if you want to do it direct, you would have to do this:
cells(i,Application.WorksheetFunction.Match("Preference", Range("1:1"), 0)).
Here is a function to find the column for X instance. I have put a subroutine in there to call it as an example for you.
Sub ColInstanceExample()
Dim MyColInstance As Long
MyColInstance = ColInstance("Preference", 2) 'Pass in what you are searching for and the instance you want to return the column number for
If MyColInstance = 0 Then
MsgBox "Not Found"
Else
MsgBox "Found at column: " & MyColInstance
End If
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function