Hey guys I am new to VBA for excel and I am stuck with a problem.
I am trying to do some calculations for data input and I have to make my program stop displaying values on the worksheet before "Discrepancy" reaches any less than 5. This then should make both columns "Money" and "Discrepancy" stop together. After, the program will then start in another column (column "I1" for "Money2" and J1" for "Discrepancy2") when t=10 is inputted into the formula and the values are displayed in Columns I2 and J2 until till the end.
I'm not sure how to stop it before it reaches and also how to stop the other column simultaneously. I'm also not sure if it will continue for another t=10.
Any advice
Sub solver2()
Dim t As Double, v As Double, i As Integer
Dim rowG As Integer, rowH As Integer
i = 0: v = 0 'related to formuala
'Range("A3").Select
'Range("D3").Select
Range("G1").Value = "Money"
Range("H1").Value = "Discrepancy"
Range("G2").Select
For t = 0 To tf Step delta
ActiveCell.Offset(i, 0) = t
ActiveCell.Offset(i, 1) = v
v = v + delta * accel(t, v)
i = i + 1
Next t
rowG = ActiveSheet.Range("G2").End(xlDown).row
rowH = ActiveSheet.Range("H2").End(xlDown).row
For i = rowG To 1 Step -1
Dim val1 As Long
val1 = ActiveSheet.Range("G" & i).Value
If (val1 > 5) Then
ActiveSheet.Range("G" & i).EntireRow.Delete
End If
Next i
For i = rowH To 1 Step -1
Dim val2 As Long
val2 = ActiveSheet.Range("G" & i).Value
If (val2 > 5) Then
ActiveSheet.Range("G" & i).EntireRow.Delete
End If
Next i
For t = 0 To 10 Step delta 'This steps it per delta input
Range("I1").Value = "Money2"
Range("J1").Value = "Discrepancy2"
Range("I2").Select
ActiveCell.Offset(i, 0) = t
ActiveCell.Offset(i, 1) = v
v = v + delta * accel(t, v)
i = i + 1
Next t
End Sub
If you just need the cells to appear empty, you could use conditional formatting to set the text and background colors the same.
You might try a do while loop instead of a for loop to set the values in the first set:
Do While t <= tf And v < 5
ActiveCell.Offset(i, 0) = t
ActiveCell.Offset(i, 1) = v
v = v + Delta * accel(t, v)
i = i + 1
t = t + Delta
Loop
I'm not sure what you intended for the other columns, but this loop would leave t at the value you would use if you mean to continue where the first column left off
Related
I want to loop each number in column A through column B.
If there is a match, that number to be looped through column C.
If there is a match, I want the results to be returned in columns E and F.
Each column will have a variable amount of rows. There can also be multiple results.
In my example the number 1 from column A is looped through column B. If a match is found 1 is now looped through column C. If there is a match then columns E and F = C and D.
Example
If your data is arranged like bellow picture,then the code would be like this.
Sub test()
Dim vDB1, vDB2, vDB3, vR()
Dim i As Long, j As Long, k As Long, n As Long
vDB1 = Range("a2", Range("a" & Rows.Count).End(xlUp))
vDB2 = Range("b2", Range("b" & Rows.Count).End(xlUp))
vDB3 = Range("c2", Range("d" & Rows.Count).End(xlUp))
Range("e2:f2").Resize(Rows.Count - 1) = Empty
For i = 1 To UBound(vDB1, 1)
For j = 1 To UBound(vDB2, 1)
If vDB1(i, 1) = vDB2(j, 1) Then
For k = 1 To UBound(vDB3, 1)
If vDB1(i, 1) = vDB3(k, 1) Then
n = n + 1
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, n) = vDB3(k, 1)
vR(2, n) = vDB3(k, 2)
End If
Next
End If
Next j
Next i
If n > 0 Then
Range("e2").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End If
End Sub
Here is a code that should do the job. But if Tab1/Tab2 values are not unique then it might do a lookup multiple times. For example if there was 1 in place of 9 in Tab 2 it would show the row with 1 twice in tab 4. If you want to avoid that you will need to modify my code
Set tab1_list = Sheets("sheet1").Range("B6:B10")
Set tab2_list = Sheets("sheet1").Range("C6:C10")
Set tab3_list_lookup = Sheets("sheet1").Range("E6:E10")
Set Tab3_List_value = Sheets("sheet1").Range("F6:F10")
Set output_location = Sheets("sheet1").Range("H6")
For Each cell1 In tab1_list
For Each cell2 In tab2_list
If cell1.Value = cell2.Value Then
For index_no = 1 To tab3_list_lookup.Cells.Count
If tab3_list_lookup.Cells(index_no).Value = cell2.Value Then
output_location.Value = tab3_list_lookup.Cells(index_no).Value
output_location.Offset(0, 1) = Tab3_List_value.Cells(index_no).Value
Set output_location = output_location.Offset(1, 0)
End If
Next index_no
End If
Next cell2
Next cell1
I am trying to write a macro which search data from one sheet and copy's to another.
But now I have a problem because I want to copy data between two searches and paste the whole data from multiple cells into one single cell.
For example in the above picture my macro:
SEARCH for "--------------" and "*****END OF RECORD"
COPIES everything in between , here example data in row 29 and 30 and from column A,B,C
PASTE all the data from multiple cells A29,B29,C29 and then A30,B30,C30 to single cell in sheet 2 say cell E2.
This pattern is reoccurring in the column A so I want to search for the next occurrence and do all the steps 1,2,3 and this time I will paste it in Sheet2 , cell E3.
Below is the code:
I am able to search my pattern but hard time in giving references to the cells in between those searched patterns and then copying all the data to ONE cell.
x = 2: y = 2: Z = 7000: m = 0: n = 0
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "---------------------" Then m = x
If ThisWorkbook.Sheets("lic").Range("A" & x) = "****** END OF RECORD" Then n = x
If (n > 0) Then
Do
For i = m To n
ThisWorkbook.Sheets("lic").Range("A" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("B" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("C" & i + 1).Copy
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y) = ThisWorkbook.Sheets("lic").Range("A" & m + 1, "C" & n - 1): y = y + 1
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y).Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value: y = y + 1
Loop While Not x > Z
'Driver's Licence #:Driver's Licence #:Driver's Licence #:
x = 2: y = 2: Z = 7000: counter = 1
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "Driver's Licence #:" Then counter = counter + 1
If (counter = 2) Then ThisWorkbook.Sheets("Sheet1").Range("B" & y) = ThisWorkbook.Sheets("lic").Range("C" & x): y = y + 1: counter = 0
If x = Z Then Exit Sub
Loop
End Sub
Considering that the search is working correctly, about the copy thing you just need to do:
Sheet2.Range("E2").value = ThisWorkbook.Sheets("lic").Range("A" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("B" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("C" & i + 1).value
The result will be something like: AIR COO; L DAT; A
--------UPDATE---------
It was hard to understand your code, so I'm write a new one. Basically it's copy what it found on sheet1 to sheet2.
Sub Copy()
Dim count As Integer 'Counter of loops to the for
Dim Z As Integer 'Limit of (?)
Dim h As Integer 'Count the filled cells on sheet2
Dim y As Integer 'Counter the columns to be copied
Z = 7000
h = 1
'Assuming that the "----" will always be on the top, the code will start searching on the second row
'if it's not true, will be needed to validate this to.
For count = 2 To Z
If Sheet1.Cells(count, 1).Value <> "****** END OF RECORD" Then
If Sheet1.Cells(count, 1).Value <> "" Then
For y = 1 To 3 'In case you need to copy more columns just adjust this for.
Sheet2.Cells(h, 1).Value = Sheet2.Cells(h, 1).Value & Sheet1.Cells(count, y).Value
Next y
h = h + 1
End If
Else
MsgBox "END OF RECORD REACHED"
Exit Sub
End If
Next count
End Sub
Maybe I don't get the full idea but this might work for you.
I'm not at all sure what you want to see in the final output, so this is an educated guess:
Sub DenseCopyPasteFill ()
Dim wsFrom, wsTo As Worksheet
Dim ur As Range
Dim row, newRow As Integer
Dim dataOn As Boolean
Dim currentVal As String
dataOn = False
newRow = 3
Set wsFrom = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
Set ur = wsFrom.UsedRange
For row = 1 To ur.Rows.Count
If wsFrom.Cells(row, 1).Value2 = "--------------" Then
dataOn = True
ElseIf wsFrom.Cells(row, 1).Value2 = "***** END OF RECORD" Then
newRow = newRow + 1
dataOn = False
ElseIf dataOn Then
currentVal = wsTo.Cells(newRow, 5).Value2
wsTo.Cells(newRow, 5).Value2 = currentVal & _
wsFrom.Cells(row, 1) & wsFrom.Cells(row, 2) & _
wsFrom.Cells(row, 3)
End If
Next row
End Sub
If you can get away without using the Windows clipboard, I would. Instead of copy/paste, here I demonstrated how you can simply add or append a value.
Add this sub:
Sub copy_range(rng As Range)
Dim str As String
str = rng.Cells(1).Value & rng.Cells(2).Value & rng.Cells(3).Value
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1).Value = str
End Sub
Then your for loop should look like this:
For i = m To n
copy_range ThisWorkbook.Sheets("lic").Range("A" & i + 1 & ":C" & i + 1)
Next i
I have a full dictionary. All the words (360 000) are in one column.
I'd like to have Column B with all words starting with "a", column C with all words starting with b...
I am trying to do a loop or something... but... It is just too long.
Any tips? Or did someone already do this vba macro?
Tks,
Stéphane.
If we start with:
Running this short macro:
Sub SeparateData()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
End Sub
will produce:
NOTE:
You may want to add some error capture logic to the NewCol calculation line.
EDIT#1:
This version may be slightly faster:
Sub SeparateDataFaster()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long, time1 As Date, time2 As Date
N = Cells(Rows.Count, 1).End(xlUp).Row
time1 = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
time2 = Now
MsgBox time1 & vbCrLf & time2
End Sub
You can try something like this.
For 360k records its take about 20sec.
To create tests data i use this sub:
Sub FillTestData()
Dim t As Long
Dim lng As Integer
Dim text As String
'Start = Timer
For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
For i = 1 To lng
Randomize
text = text & Chr(Int((26 * Rnd) + 65))
Next i
Cells(t, 1) = text
Next t
'Debug.Print Timer - Start
End Sub
And for separate:
Sub sep()
'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array
For i = 65 To 90 ' from A to Z
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) = i Then
Cells(Row_, i - 63) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
Next i
'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
Cells(Row_, 28) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
'Debug.Print Timer - Start
End Sub
You could try:
For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i
Which is just building the destination address using the first letter of the word by doing the following:
Loop through each cell in column A
Get the first letter of that cell and convert it to upper case
Find the last cell in the column starting with that letter
Move over 1 column to the right
Go up until we hit the last row of data
If the last row isn't row 1, move down another row (next blank cell)
Give this cell the same value as the cell in column A that we're assessing
You can enter the following formula:
For letter A in B Column:
=IF(UPPER(LEFT(A1,1))="A",A1,"")
For letter B in C Column:
=IF(UPPER(LEFT(A1,1))="B",A1,"")
Repeat the same for letter C, D and so on..
I need to traverse a range from the bottom of the spreadsheet to the top of the spreadsheet. The range can be discontinuous, but I have removed overlaps (I'm only concerned with the row order, so I've also reduced the column to "A") and placed the range in "Overall_Range". Since the areas can come into the range in any order, I've built a function, Get_Loop_Order, that returns an array with order in which the areas should be processed to go from bottom to top. My plan was to just iterate over each area (from bottom to top) like this:
Loop_Order = Get_Loop_Order(Overall_Range)
For A = LBound(Loop_Order) To UBound(Loop_Order)
For Each this_row In Overall_Range.Areas(Loop_Order(A)).Rows
... do stuff ...
Next this_row
Next A
I realized that the For Each on Range.Rows will not be processed in reverse order (in fact, I have no guarantee of the order at all as far as I know).
Does anyone know if there is a way to loop through a range that is guaranteed to occur in a specific row order? When I select (the use of the word "select" here should not be confused with the Excel VBA term "Selection," the code above uses "Overall_Range") a range from bottom to top (A10:A2) the loop is in that order, when I select a range from top to bottom (A2:A10) it is in that order. I have no idea what happens if I do something like Union(A10:A2, A1:A2). I'm thinking that I will have to write another function that returns an array with the order to process things, but I'd love it if someone else had another solution. Can you help?
UPDATE:
I did some more testing Here is the code:
Dim my_range As Range 'Range being tested
Dim N As Long 'Loop variable when numbers are needed
Dim M As Range 'Loop variable when ranges are needed
Set my_range = ActiveSheet.Range("A2:A10")
ActiveSheet.Range("B1").Value = "A2:A10"
ActiveSheet.Range("B1").Font.Bold = True
ActiveSheet.Range("B1").HorizontalAlignment = xlCenter
ActiveSheet.Range("B1:C1").Merge
ActiveSheet.Range("B2").Value = "Row Index"
ActiveSheet.Range("B2").Font.Bold = True
ActiveSheet.Range("B2").HorizontalAlignment = xlCenter
ActiveSheet.Range("C2").Value = "Row Iterator"
ActiveSheet.Range("C2").Font.Bold = True
ActiveSheet.Range("C2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("B" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("C" & N + 2).Value = M.Row
N = N + 1
Next M
Set my_range = ActiveSheet.Range("A10:A2")
ActiveSheet.Range("D1").Value = "A10:A2"
ActiveSheet.Range("D1").Font.Bold = True
ActiveSheet.Range("D1").HorizontalAlignment = xlCenter
ActiveSheet.Range("D1:E1").Merge
ActiveSheet.Range("D2").Value = "Row Index"
ActiveSheet.Range("D2").Font.Bold = True
ActiveSheet.Range("D2").HorizontalAlignment = xlCenter
ActiveSheet.Range("E2").Value = "Row Iterator"
ActiveSheet.Range("E2").Font.Bold = True
ActiveSheet.Range("E2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("D" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("E" & N + 2).Value = M.Row
N = N + 1
Next M
Set my_range = Union(ActiveSheet.Range("A10:A2"), ActiveSheet.Range("A1:A2"))
ActiveSheet.Range("F1").Value = "UNION(A10:A2,A1:A2)"
ActiveSheet.Range("F1").Font.Bold = True
ActiveSheet.Range("F1").HorizontalAlignment = xlCenter
ActiveSheet.Range("F1:G1").Merge
ActiveSheet.Range("F2").Value = "Row Index"
ActiveSheet.Range("F2").Font.Bold = True
ActiveSheet.Range("F2").HorizontalAlignment = xlCenter
ActiveSheet.Range("G2").Value = "Row Iterator"
ActiveSheet.Range("G2").Font.Bold = True
ActiveSheet.Range("G2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("F" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("G" & N + 2).Value = M.Row
N = N + 1
Next M
Set my_range = Union(ActiveSheet.Range("A10:A2"), ActiveSheet.Range("A1:A2"), ActiveSheet.Range("A11:A12"))
ActiveSheet.Range("H1").Value = "UNION(A10:A2,A13:A15,A11:A12)"
ActiveSheet.Range("H1").Font.Bold = True
ActiveSheet.Range("H1").HorizontalAlignment = xlCenter
ActiveSheet.Range("H1:I1").Merge
ActiveSheet.Range("H2").Value = "Row Index"
ActiveSheet.Range("H2").Font.Bold = True
ActiveSheet.Range("H2").HorizontalAlignment = xlCenter
ActiveSheet.Range("I2").Value = "Row Iterator"
ActiveSheet.Range("I2").Font.Bold = True
ActiveSheet.Range("I2").HorizontalAlignment = xlCenter
For N = 1 To my_range.Rows.Count
ActiveSheet.Range("H" & N + 2).Value = my_range.Rows(N).Row
Next N
N = 1
For Each M In my_range.Rows
ActiveSheet.Range("I" & N + 2).Value = M.Row
N = N + 1
Next M
The results are something that I cannot post because I cannot post images...sigh...they show that no matter how crazy the range is, when accessed via the Rows collection, they come in row order.
This seems to show that the rows are consistently returned in order no matter what crazy thing I do with the range if I access it via the Rows collection. I'm thinking that this means the approach of just stepping backwards through the range (as suggested in the comments) will work.
This code should do the trick.
With one clarification: From a VBA perspective Range("A2:A10") and Range("A10:A2") are exactly the same (i.e. they return the same address: $A$2:$A$10). In order to loop one way or another, you'll need to pass another argument.
EDIT
It takes the Overall_Range that you provide, then the direction of Up or Down then assigns values to variables to use in the For statement.
No selections used.
Option Explicit
Sub LoopOrderTest()
Dim Overall_Range As Range
Dim sLoopDir As String
Dim iTtlRows As Integer
Dim iLoopStep As Integer
Dim iLoopFrom As Integer
Dim iLoopTo As Integer
Dim n As Integer
Set Overall_Range = Range("A2:A10")
sLoopDir = "Up" 'or "Down"
iTtlRows = Overall_Range.Rows.Count 'Get total rows
'Assign for loop control items based on sLoopDir value
If sLoopDir = "Up" Then
iLoopFrom = 1
iLoopTo = iTtlRows
iLoopStep = 1
ElseIf sLoopDir = "Down" Then
iLoopFrom = iTtlRows
iLoopTo = 1
iLoopStep = -1
End If
Dim i As Integer 'used only to put items in cells for testing
i = 1
For n = iLoopFrom To iLoopTo Step iLoopStep
'do stuff.
'for now just print a number showing the order that the loop works through
Overall_Range.Cells(n, 1).Value = i
i = i + 1
Next n
End Sub
This shows what happens when I set sLoopDir = "Up" and run the code. Numbers ascending indicate it loops from top to bottom.
This shows what happens when I set sLoopDir = "Down" and run the code. Numbers descending indicate it loops from bottom to top.
I looked through the questions here and though there is a lot of stuff about matching similar strings with the instr function etc, there isn't much about exact matching.
I'm looping through a list of names classified by id where each id has its own corresponding benchmark. Unfortunately all the benchmark names are something along the lines of "Barclays" x Index where there are a ton of similar sounding names such as Barclays US Aggregate Index, Barclays Intermediate Us Aggregate Index etc... and just trying to match gives an output.. but the wrong data points. Here is my code for reference.. the issue is in 2nd elseif of the loop.
I was wondering if there is an easy method to resolve this.
For i = 1 To lastrow
Sheets(source).Activate
If source = "Historical" Then
If Range("A" & i).Value = delimit2 Then
benchmark_name = Sheets(source).Range("L" & i).Value
j = j + 10
name = Sheets(source).Range("A" & i + 1).Value
Sheets(output_sht).Range("D" & j - 3) = "Portfolio"
Sheets(output_sht).Range("E" & j - 3) = benchmark_name
ElseIf benchmark_name <> vbNullString _
And Range("A" & i).Value = benchmark_name Then
If IsNumeric(Sheets(source).Range("F" & i).Value) Then
Alt_return3 = Sheets(source).Range("F" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j, col1)) Then
Sheets(output_sht).Cells(j, col1) = Alt_return3 / 100
End If
End If
If IsNumeric(Sheets(source).Range("G" & i).Value) Then
Alt_return5 = Sheets(source).Range("G" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j + 1, col1)) Then
Sheets(output_sht).Cells(j + 1, col1) = Alt_return5 / 100
End If
End If
'
If IsNumeric(Sheets(source).Range("H" & i).Value) Then
Alt_returnINC = Sheets(source).Range("H" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j + 2, col1)) Then
Sheets(output_sht).Cells(j + 2, col1) = Alt_returnINC / 100
End If
Sheets(output_sht).Range("D" & j & ":E" & j + 5).NumberFormat = "0.00%"
End If
Sheets(output_sht).Range("C" & j) = period
Sheets(output_sht).Range("C" & j + 1) = period2
Sheets(output_sht).Range("C" & j + 2) = period3
Else
End If
End If
Next i
Comment as answer because I cannot comment:
Aren't you looking for the Like operator?
And you should add to the top of your code: Option compare text
More info on the like operator
I know you are looking for an exact match. However you may want to consider trying a FuzzyMatch.
http://code.google.com/p/fast-vba-fuzzy-scoring-algorithm/source/browse/trunk/Fuzzy1
You can download/import this function to your workbook and then call it with the 2 strings/names you are comparing and it will return a score.
If I were you I'd loop through all the possible names and take the highest score.
Which in your case would be 100% if you are looking for an exact match.
This will add time to your procedure but it might help you.
===EDITED
========= Here is the code. Add this to your Module.
Option Explicit
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
'To be placed in the Declarations area
'_____________________________________
Sub TestFuzzy()
Dim t As Long, a As Long, i As Long
t = GetTickCount
For i = 1 To 100000
a = Fuzzy("Sorin Sion", "Open Source")
Next
Debug.Print "Similarity score: " & a & "; " & i - 1 & " iterations took " & _
GetTickCount - t & " milliseconds"
End Sub
'TestFuzzy's result should look like:
'Similarity score: 0.3; 100000 iterations took 2094 milliseconds
'The test was done on an Intel processor at 3.2GHz
'_____________________________________
Public Function Fuzzy(ByVal s1 As String, ByVal s2 As String) As Single
Dim i As Integer, j As Integer, k As Integer, d1 As Integer, d2 As Integer, p As Integer
Dim c As String, a1 As String, a2 As String, f As Single, o As Single, w As Single
'
' ******* INPUT STRINGS CLEANSING *******
'
s1 = UCase(s1) 'input strings are converted to uppercase
d1 = Len(s1)
j = 1
For i = 1 To d1
c = Mid(s1, i, 1)
Select Case c
Case "0" To "9", "A" To "Z" 'filter the allowable characters
a1 = a1 & c 'a1 is what remains from s1 after filtering
j = j + 1
End Select
Next
If j = 1 Then Exit Function 'if s1 is empty after filtering
d1 = j - 1
s2 = UCase(s2)
d2 = Len(s2)
j = 1
For i = 1 To d2
c = Mid(s2, i, 1)
Select Case c
Case "0" To "9", "A" To "Z"
a2 = a2 & c
j = j + 1
End Select
Next
If j = 1 Then Exit Function
d2 = j - 1
k = d1
If d2 < d1 Then
'to prevent doubling the code below s1 must be made the shortest string,
'so we swap the variables
k = d2
d2 = d1
d1 = k
s1 = a2
s2 = a1
a1 = s1
a2 = s2
Else
s1 = a1
s2 = a2
End If
If k = 1 Then 'degenerate case, where the shortest string is just one character
If InStr(1, s2, s1, vbBinaryCompare) > 0 Then
Fuzzy = 1 / d2
Else
Fuzzy = 0
End If
Else '******* MAIN LOGIC HERE *******
i = 1
f = 0
o = 0
Do 'count the identical characters in s1 and s2 ("frequency analysis")
p = InStr(1, s2, Mid(s1, i, 1), vbBinaryCompare)
'search the character at position i from s1 in s2
If p > 0 Then 'found a matching character, at position p in s2
f = f + 1 'increment the frequency counter
s2 = Left(s2, p - 1) & "~" & Mid(s2, p + 1)
'replace the found character with one outside the allowable list
'(I used tilde here), to prevent re-finding
Do 'check the order of characters
If i >= k Then Exit Do 'no more characters to search
If Mid(s2, p + 1, 1) = Mid(s1, i + 1, 1) Then
'test if the next character is the same in the two strings
f = f + 1 'increment the frequency counter
o = o + 1 'increment the order counter
i = i + 1
p = p + 1
Else
Exit Do
End If
Loop
End If
If i >= k Then Exit Do
i = i + 1
Loop
If o > 0 Then o = o + 1 'if we got at least one match, adjust the order counter
'because two characters are required to define "order"
finish:
w = 2 'Weight of characters order match against characters frequency match;
'feel free to experiment, to get best matching results with your data.
'If only frequency is important, you can get rid of the second Do...Loop
'to significantly accelerate the code.
'By altering a bit the code above and the equation below you may get rid
'of the frequency parameter, since the order counter increments only for
'identical characters which are in the same order.
'However, I usually keep both parameters, since they offer maximum flexibility
'with a variety of data, and both should be maintained for this project
Fuzzy = (w * o + f) / (w + 1) / d2
End If
End Function
==================
So once you have it then just add something like this.
Dim strA, strB, hiScore(1 to 3), tempScore
With Thisworkbook.ActiveSheet
For a = 1 to .Usedrange.Rows.Count ' Scans Column 1
strA = .cells(a,1) ' Barclays Aggregate Index
For b = 1 to .usedrange.rows.count ' Compares Col 1 to Col 2
strB = .cells(b,2) ' Barclays Aggregate Other Index
tempScore = Fuzzy(strA, strB)
If tempScore > hiScore then
hiScore(1) = tempScore
hiScore(2) = a
hiScore(3) = b
End If
Next b
' Do your Action with the Best Match Here
If hiScore(1) = 1 then ' (100% - perfect match)
' Copies col 3 from the row that the best strB match was on
' to col 4 from the row strA was on
.Cells(a,4) = .Cells(hiScore(3),3)
End If
' ====
' Reset Variables
hiScore = ""
tempScore = ""
Next a
End with