I was trying to automate an Excel file which has title in both A and B columns and I have to search each word from A within B and calculate the % by using the "no of words matched/total no of words (in column A)" formula.
I'm using the below code, however its not giving me the accurate %. Can anyone help me out please.
Sub percentage()
Dim a() As String
Dim b() As String
Dim aRng As Range
Dim cel As Range
Dim i As Integer, t As Integer, clm As Integer
Set aRng = Range(Range("A1"), Range("A65536").End(xlDown))
For Each cel In aRng
a = Split(cel, " ")
b = Split(cel.Offset(, 1), " ")
d = 0
clm = 2
C = UBound(a)
If cel.Value <> "" Then
For i = LBound(a) To UBound(a)
For t = LBound(b) To UBound(b)
If UCase(a(i)) = UCase(b(t)) Then
clm = 2
Do While True
If UCase(cel.Offset(, clm)) = UCase(a(i)) Then
Exit Do
End If
If cel.Offset(, clm) = "" Then
'cel.Offset(, clm) = a(i)
Exit Do
End If
clm = clm + 1
Loop
d = d + 1
End If
Next
Next
cel.Offset(0, 2).Value = (d / c)
End If
Next
End sub
Please make the changes. c = UBound(a) + 1 'change here
Multiply by 100 and use rounding function cel.Offset(0, 2).Value = (d / c)
Your program code should work correctly.
******EDIT On 28-09-2015 *********
Another version of program considered a better approach by me for the OP's question.
**** EDIT 29-09-2015 ******
Retesting of program for different combination of words in the string revealed that this update of program is not giving consistent results in all type of situations, Hence Update of program on 28-09-2015 stands withdrawn.
Sub percentage_rev()
Dim a() As String, b() As String
Dim aRng As Range, cel As Range
Dim i As Integer, t As Integer
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
a = Split(Trim(cel), " ")
b = Split(Trim(cel.Offset(, 1)), " ")
d = 0
c = UBound(a) + 1 'change here
If cel.Value <> "" Then
If InStr(cel, cel.Offset(, 1)) Then
d = UBound(b) + 1
Else
For i = LBound(a) To UBound(a)
For t = LBound(b) To UBound(b)
If UCase(a(i)) = UCase(b(t)) Then
d = d + 1
End If
Next
Next
End If
End If
cel.Offset(0, 2).Value = (d / c) * 100 'multiply by 100 for percentage
Next
End Sub
Related
On the left is the hypothetical database. On the right is the result I would like to obtain.
I would like to print all of the items of type B, as well as the sum and the count.
I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.
Private Sub CommandButton1_Click()
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
Dim i As Integer
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
If Not dicDistincts.Exists(Cells(i, 2).Value) Then
dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
Else
dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
End If
End If
Next i
For i = 0 To dicDuplicates.Count - 1
Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i
End Sub
EDIT: I tried with countifs but it return 0 for banana, apple and strawberry
EDIT 2: I corrected the countifs. Now it works.
If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.
Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant
Set dic = New Dictionary
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
ky = Cells(i, 2).Value
If Not dic.Exists(ky) Then
arrData = Array(1, Cells(i, 3).Value)
Else
arrData = dic(ky)
arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
End If
dic(ky) = arrData
End If
Next i
Range("A1:C1").Copy Range("E1:G1")
For i = 0 To dic.Count - 1
Range("E" & i + 2) = dic.Keys(i)
Range("F" & i + 2).Resize(, 2) = dic.Items(i)
Next i
End Sub
Unique Sum and Unique Count with Double Dictionary
Option Explicit
Private Sub CommandButton1_Click()
Dim rg As Range
With Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim Data As Variant: Data = rg.Value
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
If Data(i, 1) = "B" Then
cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
End If
Next i
ReDim Data(1 To cDict.Count, 1 To 3)
i = 0
Dim Key As Variant
For Each Key In cDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Data(i, 3) = cDict(Key)
Next Key
With Range("E2").Resize(, 3)
.Resize(i).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
This should work it uses loops through all bs and addes them if to the other list
Sub countBs()
Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times
Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected
For Each B In Bs
If B = "B" Then
Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
If adder Is Nothing Then
If Range("g2") = "" Then
Set Item = Range("g2")
Else
Set Item = Range("g1").End(xlDown).Offset(1, 0)
End If
Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
Item.Offset(0, 2) = 1
Else
adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
End If
End If
Next B
End Sub
The format of the text I'm dealing with looks like this:
|John| bought an |apple|.
The goal is to find all the text between "|"(like "John" and "apple"), change its color then delete both "|".
My current code is supposed to find the first and second instances of "|", go through each character between the two positions then change its font color, deleting both "|" and loop to do the whole thing again until no "|" can be found.
My problem is it often delete and color the wrong characters. I suspect it has something to do with character positions, but I don't know where.
Relevant code looks like this:
Dim Cell As Range
Dim iChr As Integer, N As Integer, Content As Integer
Dim openPos As Long, Dim clsPos As Long
Dim textBetween As String
For Each Cell In ws.UsedRange' relevant code is going to loop through each cell of each sheet
openPos = 0
N = 1
iChr = InStr(1, Cell.Value, "|")
Do Until iChr = 0 'Loop until no "|"
openPos = InStr(openPos + N, Cell, "|", vbTextCompare) 'first "|"
clsPos = InStr(openPos + 1 + N, Cell, "|", vbTextCompare) 'second "|"
For Content = openPos To clsPos
Cell.Characters(Content, 1).Font.Color = RGB(0, 255, 0)
Next Content
N = N + 1
Cell.Characters(clsPos, 1).Delete 'delete first and second"|"
Cell.Characters(openPos, 1).Delete
iChr = InStr(1, Cell.Value, "^") 'check if there is any "|" left
Loop
Next Cell
Please try this code.
Sub FindColorAndRemove()
' 016
Const Marker As String = "|" ' change to suit
Dim Ws As Worksheet
Dim Fnd As Range, FirstFound As String
Dim Sp() As String
Dim n As Integer
Dim i As Integer
For Each Ws In ActiveWorkbook.Worksheets
' enumerate exclusions here
If Ws.CodeName <> Sheet1.CodeName Then
Set Fnd = Ws.Cells.Find(What:=Marker & "*" & Marker, _
After:=Ws.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchDirection:=xlNext)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Address
Do
With Fnd
Sp = Split(.Value, Marker)
n = 0
.Value = Join(Sp, "")
For i = 0 To UBound(Sp) - 1
If i Mod 2 Then
With .Characters(n + 1, Len(Sp(i)))
.Font.Color = vbRed
.Font.Bold = True
End With
End If
n = n + Len(Sp(i))
Next i
End With
Set Fnd = Ws.Cells.FindNext
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Address <> FirstFound
End If
End If
Next Ws
End Sub
Please pay attention to this line of code, If Ws.CodeName <> Sheet1.CodeName Then. I added it because I didn't want all sheets to be included. You can use the worksheets' tab name or code name. I recommend the CodeName because the user is less likely to change it. If you don't need the feature you can use some irrelevant criterium or delete the entire IF statement, including its End If.
Here is another approach using Collection
Sub Find_Location()
Dim iChr, StartChar, CharLen, i, j, k, m, n As Integer
Dim Ws As Worksheet
Set Ws = ActiveSheet
Dim Occurrence As Collection
For Each Cell In Ws.UsedRange
Set Occurrence = New Collection
i = Len(Cell.Text)
If i = 0 Then GoTo EndOfForLoop
j = 1
k = 0
Do Until j > i
iChr = InStr(j, Cell.Value, "|")
If iChr = 1 Then
k = k + 1
Occurrence.Add iChr
ElseIf iChr > 1 Then
k = k + 1
If Occurrence.Count = 0 Then
Occurrence.Add iChr
ElseIf Occurrence.Count > 0 Then
If (k / 2) = Int(k / 2) Then
Occurrence.Add (iChr - k)
ElseIf (k / 2) <> Int(k / 2) Then
Occurrence.Add (iChr - Occurrence.Count)
End If
End If
ElseIf iChr = 0 Then
If k = 0 Then
GoTo EndOfForLoop
Else
GoTo ModifyContent
End If
End If
j = 1 + iChr
Loop
ModifyContent:
With Cell
.Replace "|", ""
End With
m = 1
n = 2
Do Until n > k
StartChar = Occurrence.Item(m)
CharLen = (Occurrence.Item(n) - Occurrence.Item(m) + 1)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
.Font.Bold = True
End With
m = m + 2
n = n + 2
Loop
EndOfForLoop:
Next
End Sub
I have an Excel formula that operates on a pre-existing range of data.
The Excel formula is: =STDEV.S(IF(FREQUENCY(range,range),range)) , where "range" is the aforementioned range of data.
My goal is to convert this formula into VBA code.
The following code is my attempt at trying to convert the formula into VBA, as well as my visualization of the process to try and understand why it is not putting out the same result:
Private Sub CommandButton1_Click()
Dim diffArray() As Variant
Dim i As Integer
Dim x As Integer
Dim array1() As Variant, size As Integer, j As Integer
Dim freqArray1() As Variant
Dim freqArray2() As Variant, size2 As Integer, j2 As Integer
'assigns the data values to array1
size = 0
j = 0
ReDim array1(size)
For i = 3 To 15
size = size + 1
ReDim Preserve array1(size)
array1(j) = Cells(i, 2)
j = j + 1
Next i
Cells(20, 2).Value = UBound(array1)
Cells(21, 2).Value = LBound(array1)
If UBound(array1) > 1 Then Cells(19, 2).Value = WorksheetFunction.StDev_S(array1)
'setting freqArray1 to frequency(array1, array1)
freqArray1 = WorksheetFunction.Frequency(array1, array1)
Cells(20, 3).Value = UBound(freqArray1)
Cells(21, 3).Value = LBound(freqArray1)
For i = LBound(freqArray1) To (UBound(freqArray1))
Cells(2 + LBound(freqArray1) + i, 3).Value = freqArray1(i, 1)
Next i
If UBound(freqArray1) > 1 Then Cells(19, 3).Value = WorksheetFunction.StDev_S(freqArray1)
'setting freqArray2 to if(frequency(array1, array1), array1)
size2 = 0
j2 = 0
ReDim freqArray2(size2)
For i = LBound(freqArray1) To (UBound(freqArray1))
If freqArray1(i, 1) Then
size2 = size2 + 1
ReDim Preserve freqArray2(size2)
freqArray2(j2) = freqArray1(i, 1)
j2 = j2 + 1
End If
Next i
Cells(20, 4).Value = UBound(freqArray2)
Cells(21, 4).Value = LBound(freqArray2)
For i = (LBound(freqArray2)) To UBound(freqArray2)
Cells(2 + LBound(freqArray2) + i, 4).Value = freqArray2(i)
Next i
'takes the standard deviation of if(frequency(array1, array1), array1)
If UBound(freqArray2) > 1 Then Cells(19, 4).Value = WorksheetFunction.StDev_S(freqArray2)
End Sub
The data values being operated on are in the orange cells column B(array1).
The array 'frequency(array1, array1)' is in the yellow cells column C.
The array 'if(frequency(array1, array1), array1)' is in the green cells column D.
The goal is for the values in the two blue cells(B18 and D19) to be the same.
I don't understand two things:
Why are the values in the blue cells(B18 and D19) not the same?
Why do the indices of the arrays change?
One starts at '0', the next starts at '1', and the last starts at '-1'?
use a dictionary to create a unique list and use that in the StDev_S
Private Sub CommandButton1_Click()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim rngArray As Variant
rngArray = ActiveSheet.Range("B3:B15")
Dim i As Long
For i = LBound(rngArray, 1) To UBound(rngArray, 1)
On Error Resume Next
dict.Add rngArray(i, 1), rngArray(i, 1)
On Error Resume Next
Next i
If dict.Count > 0 Then
Dim unqArr As Variant
ReDim unqArr(1 To dict.Count) As Variant
i = 1
Dim key As Variant
For Each key In dict.Keys
unqArr(i) = key
i = i + 1
Next key
ActiveSheet.Cells(19, 4).Value = Application.WorksheetFunction.StDev_S(unqArr)
End If
End Sub
With this code I'm trying to search cells in a column where there is a comma character, and divide it into 2 new cells.
Next I want to Delete the original line, but it seems impossible as the value is used in FindNext operation.
What I have :
Column D Column E
Carrot Vegetable
Apple,Banana Fruit
What I need :
Column D Column E
Carrot Vegetable
Apple Fruit
Banana Fruit
What I've done :
Sub newentry()
'
' newentry Macro
'
Dim line
Dim col
Dim content
With Sheets("Feuil3").Columns("D")
Set c = .Find(",", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Select
line = ActiveCell.Row
col = ActiveCell.Column
content = ActiveCell
category = Cells(line, "E")
Dim Table() As String
Dim i As Integer
'split content in a table
Table = Split(content, ",")
'loop on table
For i = 0 To UBound(Table)
'copy result on next line
Rows(line + 1).Insert
Tableau(i) = Application.WorksheetFunction.Trim(Table(i))
Cells(line + 1, col).Value = Table(i)
Cells(line + 1, "E").Value = category
Next i
Set c = .FindNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
'where/how to do this ?
Rows(c.Row).Delete Shift:=xlUp
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
DoneFinding:
End With
End Sub
How can I delete the line that I just found ?
Thanks.
Say we have data in column D like:
Running this short macro:
Sub Restructure()
Dim N As Long, i As Long, j As Long
Dim arr1, arr2, arr3, a1, s As String
N = Cells(Rows.Count, "D").End(xlUp).Row
j = 1
arr1 = Range("D1:D" & N)
For Each a1 In arr1
s = Mid(a1, 2, Len(a1) - 2)
If InStr(s, ",") = 0 Then
Cells(j, "E").Value = "[" & s & "]"
j = j + 1
Else
arr2 = Split(s, ",")
For Each a2 In arr2
Cells(j, "E").Value = "[" & a2 & "]"
j = j + 1
Next a2
End If
Next a1
End Sub
will produce this in column E:
NOTE:
The original data is not disturbed.
insert as many lines as needed minus one below the found cell,
then simply write needed data including found cell row
don't rely on any ActiveCell, just use the c range object you found
Sub newentry()
'
' newentry Macro
'
Dim content As String, Category As String
Dim c As Range
Dim Table() As String
With Sheets("Feuil3").Columns("D")
Set c = .Find(",", LookIn:=xlValues)
If Not c Is Nothing Then
Do
content = c
Category = c.Offset(, 1).Value2
'split content in a table
Table = Split(content, ",")
c.Offset(1).EntireRow.Resize(UBound(Table)).Insert ' insert as many rows needed minus one below the found cell
c.Resize(UBound(Table) + 1).Value = Application.Transpose(Table) ' write contents in as many cells as needed, including the found one
c.Offset(, 1).Resize(UBound(Table) + 1).Value = Array(Category, Category) ' write category in as many cells as needed one column to the right of found one
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End With
End Sub
Try this code
Sub Test()
Dim a, b, x, i As Long, j As Long, k As Long
a = Range("D1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim b(1 To UBound(a) * 3, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
If InStr(a(i, 1), ",") > 0 Then
x = Split(a(i, 1), ",")
For j = LBound(x) To UBound(x)
k = k + 1
b(k, 1) = Trim(x(j))
b(k, 2) = a(i, 2)
Next j
Else
k = k + 1
b(k, 1) = a(i, 1)
b(k, 2) = a(i, 2)
End If
Next i
Columns("D:E").ClearContents
Range("D1").Resize(k, UBound(b, 2)).Value = b
End Sub
I was trying to automate an Excel file which has title in both A and B columns and I have to search each word from A within B and calculate the % by using the "no of words matched/total no of words (in column A)" formula.
I'm using the below code, however its not giving me the accurate % for which the title has repeated words (Duplicate words).
Sub percentage()
Dim a() As String, b() As String
Dim aRng As Range, cel As Range
Dim i As Integer, t As Integer
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
a = Split(Trim(cel), " ")
b = Split(Trim(cel.Offset(, 1)), " ")
d = 0
c = UBound(a) + 1
If cel.Value <> "" Then
If InStr(cel, cel.Offset(, 1)) Then
d = UBound(b) + 1
Else
For i = LBound(a) To UBound(a)
For t = LBound(b) To UBound(b)
If UCase(a(i)) = UCase(b(t)) Then
d = d + 1
End If
Next
Next
End If
End If
cel.Offset(0, 2).Value = (d / c)
Next
End Sub
If Title 1 : Really Nice pack with Nice print and Title 2 : Nice Print Nice pack then result should be 3/6 i.e. 67%.
But I'm getting a result as 100%.
Can anyone help me out please.
Titles are
Great job dud
Really Nice pack with Nice print
To give success and success process
Don’t eat too much. If you eat too much you will get sick
I have tried =noDuplicate(celladdress)
First, you should delete duplicate word in column B.
My function delete word and return array of word that not duplicate.
Function noDuplicate(ByVal str As String) As String()
Dim splitStr() As String
Dim result() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim addFlag As Boolean
splitStr = Split(UCase(str), " ")
ReDim result(UBound(splitStr))
'
result(0) = splitStr(0)
k = 0
For i = 1 To UBound(splitStr)
addFlag = True
For j = 0 To k
If splitStr(i) = result(j) Then
addFlag = False
Exit For
End If
Next j
If addFlag Then
result(k + 1) = splitStr(i)
k = k + 1
End If
Next i
ReDim Preserve result(k)
noDuplicate = result
End Function
Then calculate the percentage of number of match word and number of word in column A.
Function percentMatch(ByVal colA As String, ByVal colB As String) As Double
Dim splitColA() As String
Dim splitColB() As String
Dim i As Integer
Dim j As Integer
Dim matchCount As Integer
splitColA = Split(UCase(colA), " ")
splitColB = noDuplicate(colB)
matchCount = 0
For i = 0 To UBound(splitColA)
For j = 0 To UBound(splitColB)
If splitColA(i) = splitColB(j) Then
matchCount = matchCount + 1
Exit For
End If
Next j
Next i
percentMatch = matchCount / (UBound(splitColA) + 1)
End Function
After add these two function, you can write your new code to below
Sub percentage()
Dim aRng As Range, cel As Range
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
cel.Offset(0, 2).Value = percentMatch(cel.Value, cel.Offset(0, 1).Value)
Next
End Sub
Note, I not protect for empty string in the function.
If you F8 through the code, you can see the problem.
The first Nice in column A loops through column B and counts 2 occurences.
Pack in column A loops through column B and counts 1 occurence.
The second Nice in column A loops through column B and counts 2 occurences.
Print in column A loops through column B and counts 1 occurence.
So you get a count of 6 against the 6 words in column A; 100%
If you add a random word to column A, you'll get 6 out of 7.