I have multiple cells in excel which have duplicates in them and A column has numerous such cells. For e.g. A1=(30JNK11BR004 30JNK11AA004 30JNK11AA005 30JNK11BR004 30JNK11AA005). Between each text there is a linefeed. How do I remove the duplicates?
If one has the Dynamic Array formula UNIQUE:
=TEXTJOIN(CHAR(10),TRUE,UNIQUE(FILTERXML("<a><b>"&SUBSTITUTE(A1,CHAR(10),"</b><b>")&"</b></a>","//b")))
With cells like:
Select the cells you wish to process and run this VBA macro:
Sub deDupl()
Dim cell As Range, chr10 As String, arr
Dim c As Collection, a, temp As String
Dim i As Long
chr10 = Chr(10)
For Each cell In Selection
arr = Split(decap(cell.Value), chr10)
Set c = New Collection
On Error Resume Next
For Each a In arr
c.Add a, CStr(a)
Next a
On Error GoTo 0
temp = ""
For i = 1 To c.Count
temp = IIf(temp = "", c.Item(i), temp & chr10 & c.Item(i))
Next i
cell.Value = encap(temp)
Next cell
End Sub
Public Function decap(s As String) As String
decap = Mid(s, 2, Len(s) - 2)
End Function
Public Function encap(s As String) As String
encap = "(" & s & ")"
End Function
Cell afterwards:
Related
My spreadsheet currently has a column C with rows of data that have this structure below:
123 - abc - xyz
I want my VBA code to remove all the data before the first - including the - so that the column C would look like this:
abc - xyz
My current code is removing both "-"
Sub TrimCell()
Dim i As String
Dim k As String
i = "-"
k = ""
Columns("C").Replace what:=i, replacement:=k, lookat:=xlPart,
MatchCase:=False
End Sub
The Excel function I have for this is =REPLACE(C1,1,FIND("-",C1),""). This works but I want something in VBA.
This will work on column C:
Sub my_sub()
Dim c As Range
For Each c In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("C:C"))
c = Trim(Mid(c, InStr(c, "-") + 1))
Next
End Sub
You want to find the location of the first "-"
location = instr(1, cells(iRow,3), "-", vbTextCompare)
Taking advantage of fact that instr only returns the first entry...
Then trim the cell to the right using that location
if location > 0 then
'Found a "-" within this cell
cells(iRow,3) = right(cells(iRow,3), len(cells(iRow,3)-location)
end if
iRows is obviously just my iterator over the rows in your data. Define it whatever way you want.
You could dot it in one go using Evaluate.
With Range("C1", Range("C" & Rows.Count).End(xlUp))
.Value = Evaluate("MID(" & .Address & ", FIND(""-"", " & .Address & ")+1, LEN(" & .Address & "))")
End With
Please, try the next function:
Function replaceFirstGroup(x As String) As String
Dim arr
arr = Split(x, " - ")
arr(0) = "###$"
replaceFirstGroup = Join(Filter(arr, "###$", False), " - ")
End Function
It can be called/tested in this way:
Sub testReplaceFirstGroup()
Dim x As String
x = "123 - abc - xyz"
MsgBox replaceFirstGroup(x)
End Sub
In order to process C:C column, using the above function, please use the next code. It should be extremely fast using an array, working in memory and dropping the processing result at once:
Sub ProcessCCColumn()
Dim sh As Worksheet, lastR As Long, arr, i As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
arr = sh.Range("C2:C" & lastR).value
For i = 1 To UBound(arr)
arr(i, 1) = replaceFirstGroup(CStr(arr(i, 1)))
Next i
sh.Range("C2").Resize(UBound(arr), 1).value = arr
End Sub
How do I count the total number of "alt" and "first" that appeared in a cell and do the same for other cells as well while ignoring empty cells in the process? For instance, if a cell has first, first, alt, first, first, first, it should give me firstcounter = 5 (where firstcounter is the total count for first) and altcounter= 1(altcounter is the total count for alt). After that I can use the value of firstcounter and altcounter found to concatenate them into a string as shown in column B in the form of "first-" & firstcounter, "alt-"& altcounter.
Dim ia As Long
Dim lastrow2 As Long
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
lastrow2 = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
For ia = 2 To lastrow2
Dim arr() As Variant
' Split the string to an array
arr = Split(ws1.Cells(ia, "A"), ",").Value
'what should i do after split
Enter the following into a code module...
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Then in cell B2 enter this formula:
=CountWords(A2)
Now copy it downwards as far as you need.
Update
To use the above function from VBA without entering formulas in the worksheet you can do it like this...
Sub Cena()
Dim i&, v
With [a2:a8]
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Offset(, 1) = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Update #2
In response to your questions in the comments, you can use this variation instead...
Sub Cena()
Dim i&, v
With [a2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Cells = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
In order to make this independent from the words alt and first and whitespaces in the string I would use the following functions
Option Explicit
'Add a reference to Microsoft VBScript Regular Expressions 5.5
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
'Add a reference to Microsoft Scripting Runtime
Function CountWordsA(rg As Range) As String
On Error GoTo EH
Dim dict As Dictionary
Set dict = New Dictionary
Dim vDat As Variant
vDat = RemoveWhiteSpace(rg.Value)
vDat = Split(vDat, ",")
Dim i As Long
For i = LBound(vDat) To UBound(vDat)
If dict.Exists(vDat(i)) Then
dict(vDat(i)) = dict(vDat(i)) + 1
Else
dict.Add vDat(i), 1
End If
Next i
Dim vKey As Variant
ReDim vDat(1 To dict.Count)
i = 1
For Each vKey In dict.Keys
vDat(i) = vKey & "-" & dict(vKey)
i = i + 1
Next vKey
CountWordsA = Join(vDat, ",")
Exit Function
EH:
CountWordsA = ""
End Function
Sub TestIt()
Dim rg As Range
Set rg = Range("A2:A8")
Dim sngCell As Range
For Each sngCell In rg
sngCell.Offset(, 1) = CountWordsA(sngCell)
Next sngCell
End Sub
More about dictionaries and regular expressions
Alternative using Filter() function
This demonstrates the use of the Filter() function to count words via function UBound():
Function CountTerms() (usable also in formulae)
Function CountTerms(ByVal WordList As String, Optional TermList As String = "first,alt", Optional DELIM As String = ",") As String
'Purpose: count found terms in wordlist and return result as list
'[1] assign lists to arrays
Dim words, terms
words = Split(WordList, DELIM): terms = Split(TermList, DELIM)
'[2] count filtered search terms
Dim i As Long
For i = 0 To UBound(terms)
terms(i) = terms(i) & "-" & UBound(Filter(words, terms(i), True, vbTextCompare)) + 1
Next i
'[3] return terms as joined list, e.g. "first-5,alt-1"
CountTerms = Join(terms, ",")
End Function
Example call (due to comment) & help function getRange()
In order to loop over the entire range and replace the original data with the results list:
Sub ExampleCall()
'[1] get range data assigning them to variant temporary array
Dim rng As Range, tmp
Set rng = getRange(Sheet1, tmp) ' << change to sheet's Code(Name)
'[2] loop through array values and get counts
Dim i As Long
For i = 1 To UBound(tmp)
tmp(i, 1) = CountTerms(tmp(i, 1))
Next i
'[3] write to target (here: overwriting due to comment)
rng.Offset(ColumnOffset:=0) = tmp
End Sub
Function getRange(mySheet As Worksheet, tmp) As Range
'Purpose: assign current column A:A data to referenced tmp array
With mySheet
Set getRange = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
tmp = getRange ' assign range data to referenced tmp array
End With
End Function
I have a data of 10 x 2 dimension. The data looks like below -
year rate
05-06 10%
06-07 20.222%
07-08 13.17%
.
.
.
I want to print this data as a string within a text box present over the chart object and the format of the first column must be a text and the format of the second column must be truncated to one decimal place with a percent symbol. I have concatenated the data as string and pasted it to the text box object over the chart by mapping the cell containing the formula calling the function below.
The string format should look like below -
05-06 : 10.0% ; 06-07 : 20.2% ; 07-08 : 13.2% ...
I have stored this data as a named range rateCurrent and I have used the below code to generate the string of visible rows.
= ConcatenateVisible(rateCurrent, ":", ";")
For time being, assume I have pasted the data starting at column 3, row 8.
Function ConcatenateVisible(rng As Variant, seperator As String, separator1 As String)
For Each cll In rng
If cll.EntireRow.Hidden = False And rng.Column = 3 Then
Debug.Print rng.Row
ConcatenateVisible = ConcatenateVisible & Format(cll.Value, "#") & seperator
Debug.Print cll.Value
Else
Debug.Print rng.Row
ConcatenateVisible = ConcatenateVisible & Format(cll.Value, "0.0%") & seperator1
End If
Next
ConcatenateVisible = Left(ConcatenateVisible, Len(ConcatenateVisible) - Len(seperator))
End Function
For some reason, the second loop is not working and I am receiving the output like below -
05-06 : 10.00000000000 : 06-07 : 20.2222222222 : 07-08 : 13.1765433333 ....
I tried the below function as well which, when added the if loop for format breaks -
Public Function MakeList(ByVal myRange As Range) As String
On Error GoTo Errhand:
Dim c As Range
Dim MyDict As Object: Set MyDict = CreateObject("Scripting.Dictionary")
For i = 1 To myRange.Cells.Count
For Each c In myRange
If Not Rows(c.Row).Hidden Then
If Not MyDict.exists(c.Value2) Then MyDict.Add c.Value2, 1
End If
Next
Debug.Print c, MyDict.keys
If i Mod 2 = 0 Then
MakeList = Join(MyDict.keys, ": ")
Else
MakeList = Join(MyDict.keys, "; ")
End If
Next
cleanExit:
Set MyDict = Nothing
Set c = Nothing
Exit Function
Errhand:
Debug.Print Err.Number, Err.Description
GoTo cleanExit
End Function
Any hints or help or suggestions are much appreciated. TIA.
Try this:
Option Explicit
Function concatenateVisible(rng As Range, Optional separator As String = " : ", _
Optional separator1 As String = " ; ") As String
Dim rw As Range
Dim str As String
str = ""
For Each rw In rng.Rows
If rw.Hidden = False And Len(rw.Cells(1, 1)) > 0 Then
str = str & separator1 & _
rw.Cells(1, 1) & separator & Format(rw.Cells(1, 2), "0.0%")
End If
Next rw
concatenateVisible = Mid(str, Len(separator1))
End Function
Looking for the VBA to produce this result in a column of a sheet:
1.000000
1.000001
1.000002
…
…
1.001000
1.001001
1.001002
It can be text or number.
Thanks.
Hopefully this is a good starting point:
Sub foo()
Dim lngCount As Long
With Sheet1
For lngCount = 1 To 1002
.Range("A" & lngCount).NumberFormat = "0.000000"
.Range("A" & lngCount).Value = 1 + ((lngCount - 1) / 1000000)
Next lngCount
End With
End Sub
This would be especially suitable for a function
Public Function replacechar(str As String, charnumber As Integer, replacewith As String) As String
Dim startstr As String, endstr As String
startstr = Left(str, charnumber-1)
endstr = Right(str, Len(str) - Len(startstr))
replacechar = startstr & replacewith & endstr
End Function
You can call this function in a regular Sub, for example
Sub repl()
Dim newstr As String, c As Range
With ThisWorkbook.Sheets(1)
For Each c In .Range("A1:A100")
If not c.Value = "" Or Len(c.Value) < 5 Then
newstr = replacechar(c.Value, 5, "1") 'replaces the 5th char with "1"
c.Value = newstr
End If
Next c
End With
End Sub
This can done using NumberFormat and a Formula. the .Value2 = .Value2 converts the formula to an actual value
' Update ActiveSheet with your destination sheet reference
' Update .Cells(1,1) with reference to your starting cell - This is A1
' Update Resize(xxx) with the number of cells you want populated
With ActiveSheet.Cells(1, 1).Resize(100)
.NumberFormat = "0.000000"
.Formula = "=1 + (row()" & IIf(.Cells(1).Row > 1, " - " & .Cells(1).Row, "") & ") / 1e6"
.Value2 = .Value2
End With
I am trying to use wildcards in a formula to count cells in a table column which contain text and not ""
I tried the following methods:
String comparison
Dim g As Integer
g = Application.WorksheetFunction.CountIf(ThisWorkbook.Worksheets("ws1").ListObjects("Table1").ListColumns("ColumnA").DataBodyRange, ""*?"")
Using a tilde failed:
Dim g As Integer
g = Application.WorksheetFunction.CountIf(ThisWorkbook.Worksheets("ws1").ListObjects("Table1").ListColumns("ColumnA").DataBodyRange, ""~*?"")
Using ASCII characters below returned 0:
g = Application.WorksheetFunction.CountIf(ThisWorkbook.Worksheets("ws1").ListObjects("Table1").ListColumns("Column1").DataBodyRange, Chr(34) & Chr(63) & Chr(42) & Chr(34))
Tried and tested:
Public Function not_qt(ByVal rng As Range) As Integer
Dim cell As Range
Dim counter As Integer: counter = 0
For Each cell In rng
If Not IsEmpty(cell) Then
If Not cell Like Chr(34) & "*" & Chr(34) Then
counter = counter + 1
'cell.Offset(0, 1) = counter '<- Only for illustration purposes
End If
End If
Next cell
not_qt = counter
End Function