I have a column of Excel cells that follow this format (the random strings are not in a fixed order). Strings that don't start with a certain string need to be removed.
randomstringA text_that_needs_to_be_kept1
text_that_needs_to_be_removed1
randomstringB text_that_needs_to_be_kept2
randomstringA text_that_needs_to_be_kept3
text_that_needs_to_be_removed2
I want the cell's output to be this (linebreak must be kept):
text_that_needs_to_be_kept1
text_that_needs_to_be_kept2
text_that_needs_to_be_kept3
And not this (linebreak got removed):
text_that_needs_to_be_kept1
text_that_needs_to_be_kept2
text_that_needs_to_be_kept3
The following code will go down column A starting in row 1 and remove any line that doesn't start with a value from the array arrToKeep, keeping the linebreaks.
Option Explicit
Sub RemoveStrings()
Dim rngData As Range
Dim arrData As Variant
Dim arrLines As Variant
Dim arrToKeep As Variant
Dim idx1 As Long
Dim idx2 As Long
Dim idxRow As Long
Dim boolKeep As Boolean
arrToKeep = Array("randomstringA", "randomstringB")
Set rngData = Range("A1", Range("A" & Rows.Count).End(xlUp))
arrData = rngData.Value
For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
arrLines = Split(arrData(idxRow, 1), vbLf)
For idx1 = LBound(arrLines) To UBound(arrLines)
boolKeep = False
For idx2 = LBound(arrToKeep) To UBound(arrToKeep)
If arrLines(idx1) Like arrToKeep(idx2) & "*" Then
boolKeep = True
Exit For
End If
Next idx2
If Not boolKeep Then
arrLines(idx1) = ""
End If
Next idx1
arrData(idxRow, 1) = Join(arrLines, vbLf)
Next idxRow
rngData.Value = arrData
End Sub
In B1 place this formula =IF(LEFT(A1;1)="r";MID(A1;FIND(" ";A1;1)+1;500);"") and copy+paste to the other cells in column B.
Related
I'm trying to copy the values of a range of cells(A1:A50) into a single cell (B1). I can do it manually by copying the cells to the clipboard and then pasting the clipboard into the formuala bar of B1 but I can't find a way of doing this in a macro other than getting the cells copied to the clipboard.
Hopefully someone can help me out here.
Sheet1.Range("A1:A50").SpecialCells(xlCellTypeConstants).Select
Selection.Copy
I would like the contents of cell B1 to look something like this:
Value of cell A1
Value of cell A2
Value of cell A3
...and so on
Just
Sub myConcat(rSource As Range, rTarget As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
rTarget.Value = Right(sRes, Len(sRes) - Len(sDelimiter))
End Sub
Call it from your code like as
Sub tst_myConcat()
Call myConcat([A1:A50], [B1])
End Sub
Of course, this procedure can be easily converted to a function:
Function myConcat(rSource As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
myConcat = Right(sRes, Len(sRes) - Len(sDelimiter))
End Function
In this case, just write in the target cell (B1) =myConcat(A1:A50)
Do not forget to include in the cell format Wrap text!
First Column To String
The FirstColumnToString function (UDF) has a fixed delimiter (Delimiter) which can manually be changed. But it can e.g. do the following:
=FirstColumnToString(A1:A2,A4,A6:C8,Sheet2!A1:A3)
where it will discard error values and zero-length strings ("") and choose only values from the first column of each range e.g. in range A6:C8 it will choose the values from A6:A8.
The Code
Option Explicit
Function FirstColumnToString(ParamArray SourceRanges() As Variant) _
As String
Const Delimiter As String = vbLf & vbLf
Dim RangesCount As Long
RangesCount = UBound(SourceRanges) - LBound(SourceRanges) + 1
Dim data As Variant
ReDim data(1 To RangesCount)
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Element As Variant
Dim RowsCount As Long
Dim j As Long
For Each Element In SourceRanges
j = j + 1
If Element.Rows.Count > 1 Then
data(j) = Element.Columns(1).Value
Else
data(j) = Help
data(j)(1, 1) = Element.Columns(1).Value
End If
RowsCount = RowsCount + UBound(data(j))
Next Element
Dim Result As Variant
ReDim Result(1 To RowsCount)
Dim Current As Variant
Dim i As Long
Dim k As Long
For j = 1 To RangesCount
For i = 1 To UBound(data(j))
Current = data(j)(i, 1)
If Not IsError(Current) Then
If Current <> vbNullString Then
k = k + 1
Result(k) = Current
End If
End If
Next i
Next j
ReDim Preserve Result(1 To k)
FirstColumnToString = Join(Result, Delimiter)
End Function
A much simpler way of doing the job is to use the TREXTJOIN function in Excel:
With Sheet2.Range("A1:A50")
.AutoFilter Field:=1, Criteria1:="<>"
Sheet2.Range("B1").Value2 = WorksheetFunction.TextJoin(vbCrLf, True, _
.SpecialCells(xlCellTypeVisible))
.AutoFilter
End With
I need a dynamic way to add Note in which cell in my ID column A. However the comments need to use the information from Column B and C. ex: ON 01/13/2020, Anne.
I am not sure how to check how many times each value from column A will appear and use information from column D and B to create the comment (NOTE)..
result I need. All the time the ID number will be the same the comments need to be the same as well.
The code I am using is
Sub Cmt_test()
Sheet1.Range("A2").AddComment "On " & Sheet1.Range("D2") & ", " & Sheet1.Range("B2")
End Sub
I don't know how I can make it dynamic to get the information all the time the same ID appears. Maybe if I use Loop on column A would it be possible that all the time the loop finds the same ID to add the comment using the information from column D and B?
Write Comments to Each Cell in a Column
Option Explicit
Sub addComments()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const LastRowCol As Long = 1 ' or "A"
Const str1 As String = "On "
Const str2 As String = ", "
Dim Cols As Variant: Cols = Array(1, 2, 4)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow: LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
Dim Vals As Variant: ReDim Vals(UBound(Cols))
' Define Source Range.
Dim rng As Range: Set rng = ws.Range(ws.Cells(FirstRow, Cols(0)), _
ws.Cells(LastRow, Cols(0)))
' Write Column Ranges to Arrays.
Dim j As Long
For j = 0 To UBound(Cols)
Vals(j) = rng.Offset(, Cols(j) - Cols(0))
Next j
' Loop through elements (rows) of Source Array
' and write comments to a dictionary.
Dim dict As Object, Curr As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Vals(0))
Curr = Vals(0)(i, 1)
If dict(Curr) <> "" Then
dict(Curr) = dict(Curr) & vbLf & str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
Else
dict(Curr) = str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
End If
Next i
' Write comments from the dictionary to Source Range.
rng.ClearComments
Dim cel As Range
For Each cel In rng.Cells
cel.AddComment dict(cel.Value)
Next cel
End Sub
I have a sheet that I need to paste data to according to the validation lists in those sheets. In the sheet, there are many columns each with their own data validation list - some are written directly as "yes;no" others are references "='$$VALUES$$'!$IJ$1:$IJ$12".
What I need is to find a way to add each item in each list to an array. Using the code below I could find the references above.
Debug.Print Cells(2, 6).Validation.Formula1
Is there any elegant way to store the output as a list containing each valid input. My only idea so far is to first check which type of output I get, and then if it is the list form of "yes;no" then look for the number of ; and then split it item by item. And in case its the sheet range reference split it by sheet and range and convert that range to an array.
Something like this, will do it. I'd set a range rather than using activecell, and also check validation is present to reduce your errors.
Sub get_val_lists()
Dim arrOutput() As Variant
If Left(ActiveCell.Validation.Formula1, 1) <> "=" Then
arrOutput = Split(ActiveCell.Validation.Formula1, ",")
Else
arrOutput = Application.Transpose( _
Range(Mid(ActiveCell.Validation.Formula1, 2)).value)
End If
End Sub
I was a bit pressed for time so I ended up doing an inelegant solution myself. Posting it here in case somebody else runs into the same problem.
Sub ValidList()
Dim strFormula As String
Dim intLastSemi As Integer
Dim intCurSemi As Integer
Dim intSemi As Integer
Dim aryList() As Variant
Dim intLen As Integer
Dim blnCont As Boolean
Dim strSheet As String
Dim strRange As String
Dim intSplit As Integer
Dim ws As Worksheet
Dim rng As Range
Dim e As Variant
Dim Row As Integer
Dim Col As Integer
'This is just an example, turning it into a fucntion based on row and col later
'so now my test validation list is just in A1
Row = 1
Col = 1
strFormula = Cells(Row, Col).Validation.Formula1
intLen = Len(strFormula)
If InStr(1, strFormula, "=") Then 'Sheet reference
intSplit = InStr(1, strFormula, "!")
strSheet = Right(Left(strFormula, intSplit - 1), intLen - intSplit - 3)
strRange = Right(strFormula, intLen - intSplit)
Set ws = Worksheets(strSheet)
Set rng = ws.Range(strRange)
aryList() = rng
ElseIf Not InStr(1, strFormula, ";") Then 'Hardcoded list
intSemi = 0
intLastSemi = 0
blnCont = True
While blnCont
intCurSemi = InStr(intLastSemi + 1, strFormula, ";")
If intCurSemi <> 0 Then
intSemi = intSemi + 1
ReDim Preserve aryList(intSemi)
aryList(intSemi) = Right(Left(strFormula, intCurSemi - 1), intCurSemi - intLastSemi - 1)
intLastSemi = intCurSemi
ElseIf intCurSemi = 0 Then
intSemi = intSemi + 1
ReDim Preserve aryList(intSemi)
aryList(intSemi) = Right((strFormula), intLen - intLastSemi)
blnCont = False
End If
Wend
End If
'For my attempt at passing the array to a function
'For Each e In aryList
' MsgBox e
'Next
'ReDim ValidList(UBound(aryList))
'ValidList = aryList
End Sub
I am trying to split these names up so that are in a cell each. I have tried text to columns and that doesn't do the job.
you can use the code below to split the string by chr(10), which presents a line feed character. Please note the assumption behind input data header and output column. Please also note that dictionary works in this case only because dictionaries in VBA somehow maintains ordering - this is unlikely to be the case in other programming languages.
Public Sub sub_test()
Dim wsThis As Worksheet: Set wsThis = ActiveSheet
Dim vData As Variant
Dim dicOutput As Object: Set dicOutput = CreateObject("scripting.dictionary")
Dim vTemp As Variant
Dim vLine As Variant
Dim i As Long
With wsThis
' Read data into memory - assume no header
vData = .Range(.Range("A1"), .Range("A1").End(xlDown))
' Loop through each row
For i = LBound(vData, 1) To UBound(vData, 1)
' Split by new line
vTemp = Split(vData(i, 1), Chr(10))
For Each vLine In vTemp
' Check if new line is empty string
If Trim(vLine) <> vbNullString Then
dicOutput(vLine) = 1
End If
Next vLine
Next i
vTemp = Application.Transpose(dicOutput.keys)
' Output into worksheet - assume column C
.Range("C1").Resize(UBound(vTemp, 1) - LBound(vTemp, 1) + 1, UBound(vTemp, 2) - LBound(vTemp, 2) + 1) = vTemp
End With
End Sub
I'm trying to match (90%) partial text string from a sheet column to another sheet column and bring end result to the master sheet column.
I found a VBA solution but I have some problems with that.
1) it's matching exact text
2) finding a problem to match two different sheet columns.
Please help me to sort this out.
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("BANK STATEMENT ENTRY").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("F3:F" & TotalRows).Copy Destination:=Sheets("TEST").Range("A1")
'Go to the destination sheet
Sheets("TEST").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("INFO").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub
I have done a text mining project and I know you cannot use that approach, you have to break the strings into substrings and then analyze them. It will be a whole project, but you are lucky since I did it for you.
Let's simplify the problem and say that you have two ranges of strings and you want to find every similar strings between two groups. Also, you want to have a tolerance to minimize the matching pairs.
Assume ABCDE and 12BCD00. They have B, C, D, BC, CD and BCD in common. So the longest common substring is BCD which is 3 characters: 3/length of ABCDE(5) will be 60% similarity with the first string and 3/7=43% similarity. So if you can get a list of all those common substrings among all the strings in two ranges you can come up with a better list to filter and get what you want.
I wrote a bunch of functions. To use it easily, just copy and paste both groups of strings in one sheet and generate the final report on the same sheet too to understand how it works.
Function FuzzyFind, finds all of the common substrings and gives you 1st string from Group1/range1, 2nd string from group2/range2, common substring and percentages of similiarity for both strings. The good thing is you can tell the function how small you want your substrings e.g. in the previous example, if you say iMinCommonSubLength=3, it will only give you BCD, if you say iMinCommonSubLength=2 it will give you BC, CD and BCD and so on.
Use function Main. I also included a Test sub.
Functions:
Sub TestIt()
Call Main(ActiveSheet.Range("A1:A10"), ActiveSheet.Range("B1:B10"), 4, ActiveSheet.Range("D1"))
End Sub
Sub Main(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer, Optional rngReportUpperLeftCell As Range)
Dim arr() As Variant
Dim rngReport As Range
If rngReport Is Nothing Then Set rngReport = ActiveSheet.Range("A1")
arr = FuzzyFind(rng1, rng2, iMinCommonSubLength)
Set rngReport = rngReportUpperLeftCell.Resize(UBound(arr, 1), UBound(arr, 2))
rngReport.Value = arr
rngReport.Columns(1).NumberFormat = "#"
rngReport.Columns(2).NumberFormat = "#"
rngReport.Columns(3).NumberFormat = "#"
rngReport.Columns(4).NumberFormat = "0%"
rngReport.Columns(5).NumberFormat = "0%"
End Sub
Function GetCharacters(str As String) As Variant
Dim arr() As String
ReDim arr(Len(str) - 1)
For i = 1 To Len(str)
arr(i - 1) = Mid$(UCase(str), i, 1)
Next
GetCharacters = arr
End Function
Function GetIterations(iStringLength As Integer, iSubStringLength As Integer) As Integer
If iStringLength >= iSubStringLength Then
GetIterations = iStringLength - iSubStringLength + 1
Else
GetIterations = 0
End If
End Function
Function GetSubtrings(str As String, iSubLength As Integer) As Variant
Dim i As Integer
Dim count As Integer
Dim arr() As Variant
count = GetIterations(Len(str), iSubLength)
ReDim arr(1 To count)
For i = 1 To count
arr(i) = Mid(str, i, iSubLength)
Next i
GetSubtrings = arr()
End Function
Function GetLongestCommonSubStrings(str1 As String, str2 As String, iMinCommonSubLeng As Integer)
Dim i As Integer
Dim iLongestPossible As Integer
Dim iShortest As Integer
Dim arrSubs() As Variant
Dim arr1() As Variant
Dim arr2() As Variant
ReDim arrSubs(1 To 1)
'Longest possible common substring length is the smaller string's length
iLongestPossible = IIf(Len(str1) > Len(str2), Len(str2), Len(str1))
If iLongestPossible < iMinCommonSubLeng Then
'MsgBox "Minimum common substring length is larger than the shortest string." & _
' " You have to choose a smaller common length", , "Error"
Else
'We will try to find the first match of common substrings of two given strings, exit after the first match
For i = iLongestPossible To iMinCommonSubLeng Step -1
arr1 = GetSubtrings(str1, i)
arr2 = GetSubtrings(str2, i)
ReDim arrSubs(1 To 1)
arrSubs = GetCommonElement(arr1, arr2)
If arrSubs(1) <> "" Then Exit For 'if you want JUST THE LONGEST MATCH, comment out this line
Next i
End If
GetLongestCommonSubStrings = arrSubs
End Function
Function GetCommonElement(arr1() As Variant, arr2() As Variant) As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim arr() As Variant
count = 1
ReDim arr(1 To count)
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i) = arr2(j) Then
ReDim Preserve arr(1 To count)
arr(count) = arr1(i)
count = count + 1
End If
Next j
Next i
GetCommonElement = arr
End Function
Function FuzzyFind(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer) As Variant
Dim count As Integer
Dim i As Integer
Dim arrSubs As Variant
Dim str1 As String
Dim str2 As String
Dim cell1 As Range
Dim cell2 As Range
Dim rngReport As Range
Dim arr() As Variant 'array of all cells that are partially matching, str1, str2, common string, percentage
count = 1
ReDim arr(1 To 5, 1 To count)
For Each cell1 In rng1
str1 = UCase(CStr(cell1.Value))
If str1 <> "" Then
For Each cell2 In rng2
str2 = UCase(CStr(cell2.Value))
If str2 <> "" Then
ReDim arrSubs(1 To 1)
arrSubs = GetLongestCommonSubStrings(str1, str2, iMinCommonSubLength)
If arrSubs(1) <> "" Then
For i = 1 To UBound(arrSubs)
arr(1, count) = cell1.Value
arr(2, count) = cell2.Value
arr(3, count) = arrSubs(i)
arr(4, count) = Len(arrSubs(i)) / Len(str1)
arr(5, count) = Len(arrSubs(i)) / Len(str2)
count = count + 1
ReDim Preserve arr(1 To 5, 1 To count)
Next i
End If
End If
Next cell2
End If
Next cell1
FuzzyFind = TransposeArray(arr)
End Function
Function TransposeArray(arr As Variant) As Variant
Dim arrTemp() As Variant
ReDim arrTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For a = LBound(arr, 2) To UBound(arr, 2)
For b = LBound(arr, 1) To UBound(arr, 1)
arrTemp(a, b) = arr(b, a)
Next b
Next a
TransposeArray = arrTemp
End Function
Don't forget to clear the sheet before generating new reports. Insert a table and use its autofilter to easily filter your stuff.
last but not least, don't forget to click on the check mark to announce this as the answer to your question.