I am trying parse a number string and create rows accordingly. On the left of the Example Data picture is an example of the input data with the right being my desired output. I am wanting to insert a unique row of data for each digit within the brackets for each number combination.
Here is an example of the code I used to try to solve the problem.
Option Explicit
Sub example()
Dim num As Variant
Dim x As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim test As Variant
Dim test2 As Variant
Dim count As Integer
m = 0
For i = 1 To 3
num = Range("C" & 5 + i + m).Value
For j = 1 To Len(num)
test = Mid(num, j)
If Left(Mid(num, j), 1) = "[" Then
For k = 1 To Len(num) - (j + 1)
m = m + 1
Range("C" & 5 + m + i - 1).EntireRow.Insert
test2 = Left(Mid(num, j + k), 1)
Range("C" & 5 + m + i - 1).Value = Left(num, j - 1) + test2
Next k
End If
Next j
Next i
End Sub
Please consider using the following script:
Sub splitcombinations()
Dim rngCell As Range
Set rngCell = ThisWorkbook.Sheets(1).Range("A2")
Dim strCombinationDigits As String, strBaseDigits As String
Dim intCombinationDigitsLen As Integer
Dim x As Integer
Do While rngCell.Value2 <> ""
If InStr(rngCell.Value2, "[") > 0 Then
strCombinationDigits = Mid(rngCell.Value2, InStr(rngCell.Value2, "[") + 1, InStr(rngCell.Value2, "]") - InStr(rngCell.Value2, "[") - 1)
intCombinationDigitsLen = Len(strCombinationDigits)
strBaseDigits = Left(rngCell.Value2, InStr(rngCell.Value2, "[") - 1)
ActiveSheet.Range(rngCell.Offset(1, 0), rngCell.Offset(intCombinationDigitsLen - 1, 0)).EntireRow.Insert
For x = 1 To intCombinationDigitsLen
rngCell.Offset(x - 1, 0).Value2 = strBaseDigits & Mid(strCombinationDigits, x, 1)
rngCell.Offset(x - 1, 1).Value2 = rngCell.Offset(0, 1).Value2
rngCell.Offset(x - 1, 2).Value2 = rngCell.Offset(0, 2).Value2
Next
End If
Set rngCell = rngCell.Offset(intCombinationDigitsLen , 0)
Loop
End Sub
Related
I have two Strings in different cells for example
ADSGPINDTDANPR
RGTELDDGIQADSGPINDTDANPRY VPGYY ESQSDDPHFHEK
Also character sequences can have gaps for similar sequences like RGX in following example
LADNS TFDDDLDDLTPSKMKPANFKGD
RSLA FDDDLDDLTPSRGXKMKPANFKGDYG
What I want to do is Highlight both the sequences as shown in above example in Bold And Italic but in color using VBA code.
Edit :
As per the first answer of #milo5m
Sequence is highlighted as follows
MNTVEEVDSEEDEESAP GSV GSMPSTGSAKYYTNRVPFDMIA
EQPMNTVEEVDSEEDEESAPA
But desired result should be like this:
MNTVEEVDSEEDEESAP GSV GSMPSTGSAKYYTNRVPFDMIA
EQPMNTVEEVDSEEDEESAPA
Edit 2 :
Currently answer of #milo5m highlights single characters as shown in below examples
SKPERYSG
TAPGEQAQD
SKPERYSG
AQD QKLAPSE
In above examples no sequence should have been highlighted...
In other words, It should only highlight the Single characters when there is space before the Character, otherwise it should not highlight single characters between sequences.
It's really nice that we have these two as a reference
https://www.sciencedirect.com/science/article/pii/S0890540114000765
https://en.wikipedia.org/wiki/Longest_common_subsequence_problem
Here is the main function which is returning all subsequences forming the LCS (if you join all the keys you get the LCS in reverse subsequence form).
Function returns a dictionary where keys are subsequences, and values are arrays with 2 elements (position of subsequence in seqA and position of subsequence in seqB).
Function GetLCSSubSequenceDict(seqA As String, seqB As String) As Object
Set GetLCSSubSequenceDict = Nothing
Dim i As Long, n As Long
n = Len(seqA)
If n = 0 Then: Exit Function
Dim j As Long, m As Long
m = Len(seqB)
If m = 0 Then: Exit Function
Dim T() As Long
ReDim T(0 To n, 0 To m)
'Building up table
For i = 1 To n
For j = 1 To m
If Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
'bitwise max
T(i, j) = T(i - 1, j) Xor ((T(i - 1, j) Xor T(i, j - 1)) And --(T(i - 1, j) < T(i, j - 1)))
Else
T(i, j) = T(i - 1, j - 1) + 1
End If
Next j
Next i
Dim subseqKey As String
Dim subseqABDict As Object
Set subseqABDict = CreateObject("Scripting.Dictionary")
'Backtracking and building up dict of subsequences
'key = subsequence
'value = array(starting pos of the key in seqA,starting pos of the key in seqB)
i = n
j = m
Do While (i > 0 And j > 0)
If Not Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
subseqKey = Mid$(seqA, i, 1) & subseqKey
i = i - 1
j = j - 1
ElseIf T(i - 1, j) > T(i, j - 1) Then
If subseqKey <> vbNullString Then
subseqABDict(subseqKey) = Array(i + 1, j + 1)
subseqKey = vbNullString
End If
i = i - 1
Else
If subseqKey <> vbNullString Then
subseqABDict(subseqKey) = Array(i + 1, j + 1)
subseqKey = vbNullString
End If
j = j - 1
End If
Loop
If subseqKey <> vbNullString Then
subseqABDict(subseqKey) = Array(i + 1, j + 1)
End If
Set GetLCSSubSequenceDict = subseqABDict
Set subseqABDict = Nothing
End Function
Time complexity of the function is O ( Len(seqA) * Len(seqB) ), for those who are interested.
Following is a show case of setting font properties on 2 ranges seqA and seqB.
Sub test()
Dim seqA As Range
Dim seqB As Range
Set seqA = Range("A4")
Set seqB = Range("B4")
Dim fontColor As Long
fontColor = RGB(84, 84, 84)
Dim subseqKey As Variant
Dim lcsSubSequenceDict As Object
Set lcsSubSequenceDict = GetLCSSubSequenceDict(seqA.Value2, seqB.Value2)
'gives subsequences in reversed order, since we used backtracking
'MsgBox Join(lcsSubSequenceDict.keys())
If lcsSubSequenceDict Is Nothing Then: Exit Sub
For Each subseqKey In lcsSubSequenceDict
With seqA.Characters(lcsSubSequenceDict(subseqKey)(0), Len(subseqKey)).Font
.color = fontColor
.Bold = True
.Italic = True
End With
With seqB.Characters(lcsSubSequenceDict(subseqKey)(1), Len(subseqKey)).Font
.color = fontColor
.Bold = True
.Italic = True
End With
Next subseqKey
Set lcsSubSequenceDict = Nothing
Set seqA = Nothing
Set seqB = Nothing
End Sub
Edit:
(1) Fixed - Backtracking showing positions in sequences further to the right for multiple candidates
(2) Main Function returns Collection now (was returning Dictionary)
Function GetLCSSubSequenceCollection(seqA As String, seqB As String) As Collection
Set GetLCSSubSequenceCollection = Nothing
Dim i As Long, n As Long
n = Len(seqA)
If n = 0 Then: Exit Function
Dim j As Long, m As Long
m = Len(seqB)
If m = 0 Then: Exit Function
Dim T() As Long
ReDim T(0 To n, 0 To m)
'Building up table
For i = 1 To n
For j = 1 To m
If Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
'bitwise max
T(i, j) = T(i - 1, j) Xor ((T(i - 1, j) Xor T(i, j - 1)) And --(T(i - 1, j) < T(i, j - 1)))
Else
T(i, j) = T(i - 1, j - 1) + 1
End If
Next j
Next i
Dim subseqKey As String
Dim subseqABCollection As Collection
Set subseqABCollection = New Collection
'Backtracking and building up collection of subsequences
'value = array(subsequence, starting pos of the key in seqA,starting pos of the key in seqB)
i = n
j = m
Do While (i > 0 And j > 0)
If Not Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
subseqKey = Mid$(seqA, i, 1) & subseqKey
i = i - 1
j = j - 1
ElseIf T(i - 1, j) > T(i, j - 1) Then
If subseqKey <> vbNullString Then
subseqABCollection.Add Array(subseqKey, i + 1, j + 1)
subseqKey = vbNullString
End If
i = i - 1
Else
If subseqKey <> vbNullString Then
subseqABCollection.Add Array(subseqKey, i + 1, j + 1)
subseqKey = vbNullString
End If
j = j - 1
End If
Loop
If subseqKey <> vbNullString Then
subseqABCollection.Add Array(subseqKey, i + 1, j + 1)
End If
If subseqABCollection.Count = 0 Then: Exit Function
'fix backtracking showing positions in arrays further to the right for multiple candidates
'using inStr to chack starting from prev position etc
Dim prevSubseqPosA As Long, prevSubseqPosB As Long
prevSubseqPosA = 1
prevSubseqPosB = 1
Set GetLCSSubSequenceCollection = New Collection
For i = subseqABCollection.Count To 1 Step -1
subseqKey = subseqABCollection.Item(i)(0)
prevSubseqPosA = InStr(prevSubseqPosA, seqA, subseqKey)
prevSubseqPosB = InStr(prevSubseqPosB, seqB, subseqKey)
GetLCSSubSequenceCollection.Add Array(subseqKey, prevSubseqPosA, prevSubseqPosB)
prevSubseqPosA = prevSubseqPosA + Len(subseqKey)
prevSubseqPosB = prevSubseqPosB + Len(subseqKey)
Next
Set subseqABCollection = Nothing
End Function
Sub testCollection()
Dim lcs As String
Dim seqA As Range
Dim seqB As Range
Set seqA = Range("A4")
Set seqB = Range("B4")
Dim fontColor As Long
fontColor = RGB(84, 84, 84)
Dim lcsSubSequenceItem As Variant
Dim lcsSubSequenceCollection As Collection
Set lcsSubSequenceCollection = GetLCSSubSequenceCollection(seqA.Value2, seqB.Value2)
If lcsSubSequenceCollection Is Nothing Then: Exit Sub
For Each lcsSubSequenceItem In lcsSubSequenceCollection
With seqA.Characters(lcsSubSequenceItem(1), Len(lcsSubSequenceItem(0))).Font
.color = fontColor
.Bold = True
.Italic = True
End With
With seqB.Characters(lcsSubSequenceItem(2), Len(lcsSubSequenceItem(0))).Font
.color = fontColor
.Bold = True
.Italic = True
End With
lcs = lcs & lcsSubSequenceItem(0)
Next lcsSubSequenceItem
MsgBox lcs & " [ LEN = " & Len(lcs) & " ]"
Set lcsSubSequenceCollection = Nothing
Set seqA = Nothing
Set seqB = Nothing
End Sub
Tough challenge, and I'm not sure if it's that feasible with Excel alone. Assuming that:
You will not allow the 1st entry to have gaps;
You allow for 0+ gaps in between in the 2nd entry;
You are looking for the longest match between both entries;
You have ms365;
You may try the below answer that I based of on a formula first, see the below screenshot:
Formula in C1:
=LET(x,SCAN(,UNIQUE(TOCOL(MID(A1,SEQUENCE(LEN(A1)),SEQUENCE(1,LEN(A1))))),LAMBDA(a,b,TEXTJOIN("*",,MID(b,SEQUENCE(1,LEN(b)),1)))),y,SEARCH(x,B1),z,SORTBY(HSTACK(x,y),LEN(x)*(ISNUMBER(y)),-1),SUBSTITUTE(TAKE(FILTER(z,ISNUMBER(INDEX(z,,2))),1,1),"*",))
The above will identify the longest substring that has a match with 0+ gaps in between. This is going to be the input to the below macro:
Sub Test()
Dim ws As Worksheet, lr As Long, x As Long, y As Long, z As Long, a As Long, arr As Variant, s As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arr = ws.Range("A1:C" & lr)
For x = LBound(arr) To UBound(arr)
s = arr(x, 3)
'Format column A:A
ws.Cells(x, 1).Characters(InStr(1, ws.Cells(x, 1).Value, s), Len(s)).Font.Bold = True
ws.Cells(x, 1).Characters(InStr(1, ws.Cells(x, 1).Value, s), Len(s)).Font.Italic = True
'Format column B:B
z = 0
For y = 1 To Len(s)
z = InStr(z + 1, ws.Cells(x, 2).Value, Mid(s, y, 1))
ws.Cells(x, 2).Characters(z, 1).Font.Bold = True
ws.Cells(x, 2).Characters(z, 1).Font.Italic = True
Next
Next
End Sub
The results look like:
In Excel 365, I have data in this format:
Or, in text:
1,2,3,7 A
4 B
5 C
6, 8 D
And I'm trying to split the data so it becomes this:
Or, in text
1 A
2 A
3 A
4 B
5 C
6 D
7 A
8 D
The leftmost row is always composed by numbers separated by comma or a single number. The right row can be any data.
The following VBA code will do most of what you want:
Sub ExpandRows()
Dim R As Range
Dim Rw As Range
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim S As String
Dim Tokens(1 To 1000) As String
Dim NTokens As Integer
Const Delim As String = ","
Dim StartSize As Integer
Dim TopCell As Range
Dim BotCell As Range
Set R = Selection
Set TopCell = R.Cells(1, 1)
Set BotCell = R.Cells(R.Rows.Count, 1)
StartSize = R.Rows.Count
For I = StartSize To 1 Step -1
S = R(I, 1)
If (S <> "") Then
J = 0
NTokens = 0
Do
K = InStr(J + 1, S, Delim)
If (K = 0) Then
NTokens = NTokens + 1
Tokens(NTokens) = Mid$(S, J + 1, Len(S) - J)
Else
NTokens = NTokens + 1
Tokens(NTokens) = Mid$(S, J + 1, (K - J - 1))
J = K
End If
Loop Until (K = 0)
End If
If (NTokens > 1) Then
For J = NTokens To 2 Step -1
If (Tokens(J) <> "") Then
Set Rw = R.Cells(I, 1).EntireRow
Call Rw.Select
Call Rw.Copy
Call R.Cells(I + 1, 1).EntireRow.Select
Call Rw.Insert(xlDown)
If (I = 1) Then
Set TopCell = TopCell.Cells(0, 1)
Set R = Range(TopCell, BotCell)
End If
Call R.Select
Call R.Cells(I + 1, 1).Select
R(I + 1, 1) = Tokens(J)
End If
Next J
R(I, 1) = Tokens(1)
End If
Next I
End Sub
This code will split the cells and create new rows with a single entry.
To use it, select the first column and execute the method.
After that, all you have to do is sort on the first column.
i have problem with my code in vba. I have to find how much similar numbers are in column 1 and 2, but for example Column 1 (6,6,34,21,23,40) and column2 (49,34,6,9,6,20) should write 3 cause there are pairs 6-6, 6-6 and 34-34. I know its messy explenation but i hope its understandable. My code so far is:
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Range("B2:C7").Interior.Color = RGB(135, 134, 125)
Range("B2:B7").Font.ColorIndex = 3
Range("C2:C7").Font.ColorIndex = 5
ileLosowan = 7
Randomize
For i = 2 To ileLosowan
x = Int(Rnd * (49) + 1)
Range("c" & i) = x
Next i
For i = 2 To 7
liczba = Range("c" & i)
For j = 2 To 7
liczbe = Range("b" & j)
If liczbe = liczba Then
Range("c" & i).Interior.Color = RGB(255, 255, 0)
Range("b" & j).Interior.Color = RGB(255, 255, 0)
suma = suma + 1
End If
Next j
Next i
Range("c" & 9) = suma
End Sub
Try this. I invested some time and I added some lines of code. The macro find all the number pairs.
Example (6,6,3,4,2) (2,3,6,9,0) --> results 3: (6-6, 3-3, 2-2)
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Dim str_B As String, str_C As String, str_BC As String
Dim max_rand As Long
ileLosowan = 20 ' you can change the number of element in the column
max_rand = 49 ' max randum number
start_row = 2 'start_row
str_BC = "B2:C" & ileLosowan
str_B = "B2:B" & ileLosowan
str_C = "C2:C" & ileLosowan
Range(str_BC).Interior.Color = RGB(135, 134, 125)
Range(str_B).Font.ColorIndex = 5
Range(str_C).Font.ColorIndex = 5
Randomize
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("C" & i) = x
Next i
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("B" & i) = x
Next i
liczba_array = Range("B" & start_row & ":B" & ileLosowan).Value2
liczbe_array = Range("C" & start_row & ":C" & ileLosowan).Value2
ReDim ID_array(1 To 1)
ID_array(1) = max_rand + 1
Count = 1
For i = 1 To UBound(liczba_array, 1)
For j = 1 To UBound(liczbe_array, 1)
For k = 1 To UBound(ID_array, 1)
If ID_array(k) = j Then
GoTo out
End If
Next k
If liczba_array(i, 1) = liczbe_array(j, 1) Then
Range("B" & (start_row + i - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
Range("C" & (start_row + j - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
suma = suma + 1
ID_array(Count) = j
Count = Count + 1
ReDim Preserve ID_array(1 To Count)
Exit For
End If
Next j
out:
Next i
Range("C" & ileLosowan + 2) = suma
End Sub
Something like this will do what you're after. Just incorporate it into you're code cause I don't really know what's going on there.
Dim i As Long, j As Long, arr As Variant, Total As Integer
For i = 2 To 7 'Rows to loop through in the column
Total = 0
arr = Split(Range("A" & i), ",") 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Range("B" & i), arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
Range("C" & i) = Total 'Write total to another column on same row
Next i
Or if you want a basic function for it that you can use in your sheet you can use this:
Public Function CountMatches(Cell As String, Rng As Range, Optional Delim As String)
Dim i As Long, j As Long, arr As Variant, Total As Integer
If Delim = "" Then Delim = ","
If Rng.Count > 1 Then
CountMatches = "Please choose 1 cell to compare to."
Exit Function
End If
Total = 0
arr = Split(Cell, Delim) 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Rng, arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
CountMatches = Total
End Function
Use it like =CountMatches(A1,B1,",")
I am trying to apply the bold format to all words before a colon (:) in a specific cell. In the image, the words first / second / third need to be in bold, the rest not.
I found the following code on a different thread, but it applies the bold format to the first word before a colon.
Sub PreColon()
Dim i As Long, N As Long, s As String, j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
s = Cells(i, 1)
j = InStr(1, s, ":")
If j <> 0 Then
Cells(i, 1).Characters(1, j - 1).Font.Bold = True
End If
Next i
End Sub
split on the - and do a second loop:
Sub PreColon()
With ActiveSheet
Dim N As Long
N = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 1 To N
Dim strLen As Long
strLen = 0
Dim sArray() As String
sArray = Split(.Cells(i, 1), "-")
Dim s As Variant
For Each s In sArray
Dim j As Long
j = InStr(s, ":")
If j > 0 Then
.Cells(i, 1).Characters(strLen + 1, j - 1).Font.Bold = True
End If
strLen = strLen + Len(s) + 1
Next s
Next i
End With
End Sub
Here is a little procedure you can use:
Sub Test()
Dim i As Long, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
FormatPreColon Cells(i, 1)
Next
End Sub
Sub FormatPreColon(Rng As Range)
Dim i As Long, j As Long
If TypeName(Rng.Value) <> "String" Then Exit Sub
i = InStr(1, Rng, ":")
Do While i <> 0
j = InStrRev(Rng, " ", i) + 1
Rng.Characters(j, i - j).Font.Bold = True
i = InStr(i + 1, Rng, ":")
Loop
End Sub
Possible missing "-" symbol you may use this.
Dim i As Long, s As String, j As Integer, k As Integer, t As String, counter As Integer, N As Integer
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
s = Cells(i, 1)
j = 1
k = 1
Do While j > 0
j = InStr(k, s, ":")
k = j + 1
counter = 1
For m = j - 1 To 1 Step -1
t = Trim(Mid(s, m, 1))
If (t = "" Or m = 1) Then
Cells(i, 1).Characters(m, counter).Font.Bold = True
Exit For
Else
counter = counter + 1
End If
Next m
Loop
DoEvents
Next i
MsgBox "Finito..."
I have dataset in the format "Ping 172.123.123.123=[150ms]". How can i get the sum of what is within "[" and "]"?. I have many rows and columns and was hoping to get the SUM or AVERAGE of all ping
Example in the screen shot
Assuming that each cell ends with ]
Public Function SumPings(CellsToSum As Range)
Dim runtot As Double
Dim r As Range
Dim x As Integer
Dim y As Integer
Dim s As String
For Each r In CellsToSum
x = InStr(r.Text, "[")
If x > 0 Then
s = Mid(r.Text, x + 1, Len(r.Text) - x - 1)
runtot = runtot + Val(s)
End If
Next r
SumPings = runtot
End Function
This will sum each column and add the total to the last row of each column:
Sub foo()
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
Dim Str As String
Dim Extract_value As Integer
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
LastCol = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Column
x = 1
For x = 1 To LastCol
For i = 1 To LastRow
Str = Sheet1.Cells(i, x).Value
On Error Resume Next
openPos = InStr(Str, "[")
On Error Resume Next
closePos = InStr(Str, "m")
On Error Resume Next
midBit = Mid(Str, openPos + 1, closePos - openPos - 1)
If openPos <> 0 And Len(midBit) > 0 Then
Extract_value = Extract_value + midBit
End If
Sheet1.Cells(LastRow + 1, x).Value = Extract_value
Next i
Next x
End Sub