I use the code below to search and replace a part of a text in a string. It works fine for almost 97 % of the replacements but not when one string that is supposed to be replaced is identical with another part of the string. Is there a straightforward method to avoid this?
Sub Macro1()
Dim i As Integer
For i = 2 To Worksheets("table1").Range("A1").End(xlDown).Row
Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i), Replacement:=Worksheets("table2").Range("B" & i), LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next i
End Sub
Important: The delimiter is not always ",". It can also be any combination blank space(s) with a comma. Examples:
", "
" ,"
" , "
This is what is called a False Positive. If the delimiter is going to be always , then split the string. Do the replace and then join them again.
Is this what you are trying? I have commented the code. If you still have questions then simply ask.
Option Explicit
'~~> This is the delimiter. Change as applicable
Private Const Delim As String = ","
Sub Sample()
Dim wsTblA As Worksheet
Dim wsTblB As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ArTable1 As Variant
Dim ArTable2 As Variant
'~~> Change this to the relevant worksheet
Set wsTblA = Worksheets("Table2")
Set wsTblB = Worksheets("Table1")
'~~> Get the values in Col A and B from Sheet Table2 in an array
With wsTblA
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
ArTable2 = .Range("A2:B" & lRow).Value2
End With
'~~> Get the values in Col H from Sheet Table1 in an array
With wsTblB
lRow = .Range("H" & .Rows.Count).End(xlUp).Row
ArTable1 = .Range("H2:H" & lRow).Value2
End With
'~~> Loop through the array
For i = LBound(ArTable2) To UBound(ArTable2)
For j = LBound(ArTable1) To UBound(ArTable1)
'~~> Check if the search string is present
If InStr(1, ArTable1(j, 1), ArTable2(i, 1), vbTextCompare) Then
'~~> If it is present then attempt a replace
ArTable1(j, 1) = ReplaceText(ArTable1(j, 1), ArTable2(i, 1), ArTable2(i, 2))
End If
Next j
Next i
'~~> Write the array back to the worksheet
wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1
End Sub
'~~> Function to split the text and then compare. If exact match, then replace
Private Function ReplaceText(CellValue As Variant, ReplaceWhat As Variant, ReplaceWith As Variant) As String
Dim tmpAr As Variant
Dim ReplacedText As String
Dim k As Long
'~~> Split the test using the delimiter
tmpAr = Split(CellValue, Delim)
'~~> If exact match, then replace
For k = LBound(tmpAr) To UBound(tmpAr)
If UCase(Trim(tmpAr(k))) = UCase(Trim(ReplaceWhat)) Then
tmpAr(k) = ReplaceWith
End If
Next k
'~~> Rejoin using delimiter
ReplacedText = Join(tmpAr, Delim)
ReplaceText = ReplacedText
End Function
Sheets TABLE2
Sheets TABLE1
Sheets TABLE1 OUTPUT
EDIT
Thank you for your wonderful solution. Problem is the delimiter is not always ",". It can also be a blank space " ". Problem using a blank space as additional delimiter might be the case that each element of the string e. g. "4711 Text_A" always has a blank space after the first 4 chars. – D3merzel 44 mins ago
In that case, you can take another approach. The text can appear in 3 positions. At the begining (TEXT & Delim), in the middle (Delim & TEXT & Delim) and in the end (Delim & TEXT)
Can you try the below code. I have not extensively tested it. If you find a scenario where it doesn't work then share it, I will tweak the code.
Option Explicit
'~~> This is the delimiter. Change as applicable
Private Const Delim As String = " "
Sub Sample()
Dim wsTblA As Worksheet
Dim wsTblB As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ArTable1 As Variant
Dim ArTable2 As Variant
'~~> Change this to the relevant worksheet
Set wsTblA = Worksheets("Table2")
Set wsTblB = Worksheets("Table1")
'~~> Get the values in Col A and B from Sheet Table2 in an array
With wsTblA
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
ArTable2 = .Range("A2:B" & lRow).Value2
End With
'~~> Get the values in Col H from Sheet Table1 in an array
With wsTblB
lRow = .Range("H" & .Rows.Count).End(xlUp).Row
ArTable1 = .Range("H2:H" & lRow).Value2
End With
'~~> Loop through the array
For i = LBound(ArTable2) To UBound(ArTable2)
For j = LBound(ArTable1) To UBound(ArTable1)
'~~> Check if the search string is present
If Left(ArTable1(j, 1), Len(ArTable2(i, 1) & Delim)) = ArTable2(i, 1) & Delim Then
ArTable1(j, 1) = Replace(ArTable1(j, 1), ArTable2(i, 1) & Delim, ArTable2(i, 2) & Delim)
ElseIf InStr(1, ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, vbTextCompare) Then
ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, Delim & ArTable2(i, 2) & Delim)
ElseIf Right(ArTable1(j, 1), Len(Delim & ArTable2(i, 1))) = Delim & ArTable2(i, 1) Then
ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1), Delim & ArTable2(i, 2))
End If
Next j
Next i
'~~> Write the array back to the worksheet
wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1
End Sub
Sheets TABLE2
Sheets TABLE1
Sheets TABLE1 OUTPUT
EDIT
The above code handles all the ranges in one go! But if the code is too overwhelming (which it should not be), the above code can be reduced to a function to handle say individual string. One can use this function to check if the replace is happening correctly using a single string. For example
Debug.Print SidRepcl("bbb b_ bb b__ ccc_ bb b_ ccc", "ccc_", "ccc", " ")
Output: bbb b_ bb b__ ccc bb b_ ccc
As I mentioned earlier, all my codes above are based on the below logic
Logic: The text can appear in 3 positions. At the begining (TEXT & Delim), in the middle (Delim & TEXT & Delim) and in the end (Delim & TEXT)
Option Explicit
Function SidRepcl(txt As String, srch As String, repl As String, Delim As String) As String
Dim i As Long
Dim RetVal As String: RetVal = txt
'~~> Check if the search string is present
If Left(txt, Len(srch & Delim)) = srch & Delim Then
RetVal = Replace(txt, srch & Delim, repl & Delim)
ElseIf InStr(1, txt, Delim & srch & Delim, vbTextCompare) Then
RetVal = Replace(txt, Delim & srch & Delim, Delim & repl & Delim)
ElseIf Right(txt, Len(Delim & srch)) = Delim & srch Then
RetVal = Replace(txt, Delim & srch, Delim & repl)
End If
SidRepcl = RetVal
End Function
Flexible solution with any combinations of blank space(s) with comma(ta)
As alternative to Siddharth 's approaches you could change the logic by
splitting the input text via the ►search string itself instead of applying punctuation delimiters like e.g. ", ", "," or " ";
checking the last character in the current token and the starting character in each following token to execute replacements.
The following (edited 2023-01-02) function solves the additional requirements in comment that
... the delimiter is not always ",". It can also be a blank space " ". Problem using a blank space as additional delimiter might be the case that each element of the string e. g. "4711 Text_A" always has a blank space after the first 4 chars
by checking only one right or left neighbour character to each contained search string for " " or "," (c.f. returned helper function result IsMatch = curEndChar Like "[ ,]" And nxtStartChar Like "[ ,]" as well as comments to function TMreplc()).
Note that the substitution logic doesn't focus only to these evident delimiters but will change input strings like e.g. "4711 TEXT_A" also to e.g. 4711 TEXT_A/1.
Function TMreplc(txt As String, srch As String, repl As String) As String
'a) special case: replace entire text if identical to search string
If txt = srch Then TMreplc = repl: Exit Function
'b) get tokens by splitting via "search string" itself
Dim tokens: tokens = Split(txt, srch)
Dim ub As Long: ub = UBound(tokens)
'c) remember penultimate item
Dim mem As String: If ub > 0 Then mem = tokens(ub - 1)
'd) check most right token for content
Dim chk As Boolean: chk = tokens(ub) = vbNullString
If chk And ub > 0 Then
tokens(ub - 1) = tokens(ub - 1) & IIf(Len(mem) = 0, srch, repl)
If ub = 1 And tokens(0) = vbNullString Then tokens(0) = repl
End If
'e) Check predecessing tokens for substitutability
Dim i As Long
For i = 0 To ub - IIf(chk, 2, 1) ' if no srch finding at all (ignores: 0 To -1)
tokens(i) = tokens(i) & IIf(IsMatch(tokens, i), repl, srch)
Next i
'f) return result string
TMreplc = Join(tokens, vbNullString)
End Function
Function IsMatch(tokens, ByVal idx) As Boolean
Dim curEndChar As String
curEndChar = Right(IIf(idx = 0 And Len(tokens(0)) = 0, " ", "") & tokens(idx), 1)
Dim nxtStartChar As String: nxtStartChar = Left(tokens(idx + 1), 1)
IsMatch = curEndChar Like "[ ,]" And nxtStartChar Like "[ ,]"
End Function
Output examples
History
My first incomplete attempt below tried to include the cited additional requirement by checking only the following character, but didn't take into account those cases where the search string included preceding characters in the current token. I leave this attempt for learning purposes. - See Siddharth 's helpful comments that pointed me in the right direction.
A. First incomplete try
Function replc(txt As String, srch As String, repl As String) As String
'a) split input text into tokens via srch delimiter
Dim tokens: tokens = Split(txt, srch)
Dim ub As Long: ub = UBound(tokens)
'b) check possible change in last search item
Dim chg As Boolean: chg = tokens(ub) = vbNullString
If chg Then tokens(ub - 1) = tokens(ub - 1) & repl
'c) modify tokens
Dim i As Long
For i = 0 To ub - IIf(chg, 2, 1)
Dim nxtStartChar As String: nxtStartChar = Left(tokens(i + 1), 1)
tokens(i) = IIf(nxtStartChar Like "[ ,]", tokens(i) & repl, tokens(i) & srch)
Next i
'd) return joined tokens
replc = Join(tokens, vbNullString)
End Function
Additional note
It might be instructive, too how I tried to solve the original question (originally without the need of a different delimiter than ", "). Note the 2nd argument in the Match() function passed as array of a single string value.
Function replc2(txt As String, srch As String, repl As String) As String
Dim tokens: tokens = Split(txt, ", ")
Dim mtch: mtch = Application.Match(tokens, Array(srch), 0)
Dim i As Long
For i = 1 To UBound(mtch)
If IsNumeric(mtch(i)) Then tokens(i - 1) = repl
Next i
replc2 = Join(tokens, ", ")
End Function
B. My second try (as of 2022-12-13) includes a helper function IsMatch, but failed on certain scenarios (e.g. if the input txt is 100% identical to the search string - see last edit on top of post); I include it only for comparison reasons to complete history:
Function replc(txt As String, srch As String, repl As String) As String
Dim tokens: tokens = Split(txt, srch)
Dim i As Long
Dim ub As Long: ub = UBound(tokens)
Dim chg As Boolean: chg = tokens(ub) = vbNullString
If chg Then tokens(ub - 1) = tokens(ub - 1) & repl
For i = 0 To ub - IIf(chg, 2, 1)
tokens(i) = tokens(i) & IIf(IsMatch(tokens, i), repl, srch)
Next i
replc = Join(tokens, vbNullString)
End Function
Function IsMatch() - see top of post
Replace in Delimited Strings
Main
Sub ReplaceData()
Const SRC_DELIMITER As String = ","
Const DST_DELIMITER As String = ", "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source range to an array.
Dim sws As Worksheet: Set sws = wb.Sheets("Table2")
If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
Dim srg As Range
Set srg = sws.Range("A2:B" & sws.Cells(sws.Rows.Count, "A").End(xlUp).Row)
Dim Data(): Data = srg.Value
' Sort the array by length descending so that the longer strings
' are first matched to avoid finding shorter strings before longer ones.
BubbleSortDataByLen Data, 1, True
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = TwoColumnsToDictionary(Data, 1, 2)
' Write the values from the destination range to an array.
Dim dws As Worksheet: Set dws = wb.Sheets("Table1")
If dws.AutoFilterMode Then dws.AutoFilterMode = False ' turn off AutoFilter
Dim drg As Range
Set drg = dws.Range("H2", dws.Cells(dws.Rows.Count, "H").End(xlUp))
Data = drg.Value
' Replace.
ReplaceSingleColumnData Data, dict, SRC_DELIMITER, DST_DELIMITER
' Write back to the range.
drg.Value = Data
' Inform
MsgBox "Data replaced.", vbInformation
End Sub
Sort
Sub BubbleSortDataByLen( _
ByRef Data() As Variant, _
ByVal SortColumnIndex As Long, _
Optional ByVal Descending As Boolean = False)
Dim rLB As Long, rUB As Long: rLB = LBound(Data, 1): rUB = UBound(Data, 1)
Dim cLB As Long, cUB As Long: cLB = LBound(Data, 2): cUB = UBound(Data, 2)
Dim T, i As Long, j As Long, c As Long, IsNotsorted As Boolean
For i = rLB To rUB - 1
For j = rLB + 1 To rUB
If Descending Then
If Len(CStr(Data(i, SortColumnIndex))) < Len(CStr( _
Data(j, SortColumnIndex))) Then IsNotsorted = True
Else
If Len(CStr(Data(i, SortColumnIndex))) > Len(CStr( _
Data(j, SortColumnIndex))) Then IsNotsorted = True
End If
If IsNotsorted Then
For c = cLB To cUB
T = Data(i, c): Data(i, c) = Data(j, c): Data(j, c) = T
Next c
End If
Next j
Next i
End Sub
Dictionary
Function TwoColumnsToDictionary( _
Data() As Variant, _
ByVal KeyColumnIndex As Long, _
ByVal ItemColumnIndex As Long, _
Optional ByVal MatchCase As Boolean = False) _
As Object
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = IIf(MatchCase, vbBinaryCompare, vbTextCompare)
Dim r As Long, kStr As String
For r = LBound(Data, 1) To UBound(Data, 1)
kStr = CStr(Data(r, KeyColumnIndex))
If Len(kStr) > 0 Then ' exclude blanks
' Use the first occurrences if any duplicates (shouldn't be any).
If Not dict.Exists(kStr) Then
dict(kStr) = CStr(Data(r, ItemColumnIndex))
End If
End If
Next r
If dict.Count = 0 Then Exit Function
Set TwoColumnsToDictionary = dict
End Function
Replace
Sub ReplaceSingleColumnData( _
ByRef Data() As Variant, _
ByVal dict As Object, _
ByVal InDelimiter As String, _
ByVal OutDelimiter As String)
Dim r As Long, n As Long
Dim sStrings() As String, sStr As String
For r = LBound(Data, 1) To UBound(Data, 1)
sStr = CStr(Data(r, 1))
If Len(sStr) > 0 Then
sStrings = Split(sStr, InDelimiter)
For n = 0 To UBound(sStrings)
sStr = Application.Trim(sStrings(n)) ' reusing 'sStr'
If dict.Exists(sStr) Then
sStrings(n) = dict(sStr)
Else
sStrings(n) = sStr
End If
Next n
Data(r, 1) = Join(sStrings, OutDelimiter)
End If
Next r
End Sub
you may want to stick to the Range.Replace() approach as much as possible
Option Explicit
Sub Macro1()
Const delimiter As String = " "
With Worksheets("table2") ' reference the find&replace sheet
Dim findRng As Range
Set findRng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)) ' set the range in referenced sheet from column A row 2 down to last not empty row
End With
With Worksheets("table1") ' reference the data sheet
With .Range("H1", .Cells(.Rows.Count, "H").End(xlUp)) ' reference referenced sheet column "H" range from row 1 down to last not empty row
'-----------
'normalize the referenced range values to:
' - start with the delimiter
' - end with delimiter
' - only single spaces
Dim cel As Range
For Each cel In .Cells
cel.Value = delimiter & WorksheetFunction.Trim(cel.Value) & delimiter
Next
.Replace what:=" " & delimiter, replacement:=delimiter, lookat:=xlPart
.Replace what:=delimiter & " ", replacement:=delimiter, lookat:=xlPart
'-----------
' do the replacement
For Each cel In findRng
.Replace what:=cel.Value & delimiter, replacement:=cel.Offset(, 1) & delimiter, _
lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
' un-normalize the references range
' - remove leading delimiters
' - remove trailing delimiters
For Each cel In .Cells
cel.Value = Mid$(cel.Value, 2, Len(cel.Value) - 2)
Next
End With
End With
End Sub
Where you only have to set the needed delimiter in Const delimiter As String = " "
Of course, should you suffer from speed issues, you can switch to a "range to array" approach.
First by acting on the "normalize" and "un-normalize" code sections, only
If necessary, acting on the "do the replacement" section, too
For simplicity, this should work
Sub Macro1()
Dim i As Integer
Dim rng As Range
Set rng = Application.Intersect(Worksheets("table1").Range("H:H"), Worksheets("table1").UsedRange)
endDel = ", , ,,,"
For Each cell1 In rng
cell1.Value = cell1.Value & endDel
Next cell1
For i = 2 To Worksheets("table1").Range("A1").End(xlDown).Row
Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i) & " ", _
Replacement:=Worksheets("table2").Range("B" & i) & " ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i) & ",", _
Replacement:=Worksheets("table2").Range("B" & i) & ",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
Next i
rng.Replace What:=endDel, _
Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
End Sub
If you have multiple delimiters, I assume they don't really matter and the string doesn't need to be completely identical apart from the replacements. Assuming that, the easiest way would be just to replace all the possible delimiters, with just one. You can then easily split the string, test each individually then recombine for a standardised string.
Example code uses Split(", # ,# , ", "#") with a delimiter that is not , for ease
Sub Blah()
Debug.Print Replacement("A, B , d,e,f,g , h", "e", "G")
End Sub
Function Replacement(strInput As String, ToFind As String, ToReplace As String) As String
Dim i As Long
Dim DelimArray() As String: DelimArray = Split(", # ,# , ", "#")
For i = LBound(DelimArray) To UBound(DelimArray)
strInput = Replace(strInput, DelimArray(i), ",")
Next i
Dim TextArray() As String: TextArray = Split(strInput, ",")
For i = LBound(TextArray) To UBound(TextArray)
If TextArray(i) = ToFind Then TextArray(i) = ToReplace
Next i
Replacement = Join(TextArray, ",")
End Function
Problem: The Range.Replace method (Excel) generates unreliable results under the following conditions:
The strings to be replaced are also part of other strings.
Strings in the target range have multiple delimiters.
The strings to be replaced contain one or more of the delimiters.
Data:
Old (What)
New (Replacement)
4711 TEXT_A
4711 TEXT_A/1
4710 TEXT_B
4710 TEXT_B/1
String
4711 TEXT_A 4710 TEXT_B 4711 TEXT_AA,4710 TEXT_BB , 4711 TEXT_A , 4710 TEXT_B,4711 TEXT_AA, 4710 TEXT_BB, 4711 TEXT_A,4710 TEXT_B, 4711 TEXT_AA, 4710 TEXT_BB
The string above presents all the conditions previously mentioned:
Solution Proposed:
This problem can be solved using the Range_Replace_With_MultiDelimiters procedure:
Syntax
Range_Replace_With_MultiDelimiters (rTarget, aDelimiters, aOldNew, [blIncludeFormulas])
Parameters
Remarks
Delimiters that contain other delimiters must be placed in the array before the delimiters it contains, e.g.:
Variables:
Method:
1 - Mask all sOld strings to be replaced: As the strings to be replaced may contain one or more of the delimiters; when we try to standardize the delimiters, the sOld strings contained in the target strings will be affected, particularly when the delimiter is {space} therefore we need to modify (Mask) the sOld strings before standardizing the delimiters.
To do this we define a one-character constant to be used as a Mask Character:
Const kMsk As String = "‡"
This character must not be present in the rTarget range, nor in any sNew string.
The sOld will be masked using the format ‡i‡, where i (position of sOld in the aOldNew array) is wrapped with the Mask Character ‡.
2 - Standardize the Delimiters: Define a one-character constants to be used as Standard Delimiter:
Const kChr As String = "§" '(ASCII code 167)
This character must not be present in the rTarget range, nor in any sNew string.
Then convert all delimiters to a Standard Delimiter Index using the format §i§, where i (position of the delimiter in the array) is wrapped by the Standard Delimiter §.
This is the standardizing formula:
= "§" & SUBSTITUTE( … SUBSTITUTE( rTarget, aDelimiters(1), "§1§" ) … , aDelimiters(n), "§n§") & "§"
After the entire replacement process is completed, all delimiters will be reset to their original value. This is the reset formula:
= SUBSTITUTE(SUBSTITUTE( … SUBSTITUTE( rTarget, "§1§", aDelimiters(1) ), … , "§n§", aDelimiters(n) ), "§", TEXT(,) )
These formulas will be created by the function: Range_Replace_ƒDelimiters_Formula and applied to the rTarget using the Application.Evaluate method (Excel).
3 - Replace masked sOld strings with sNew string: Before replacing the masked sOld strings with the corresponding sNew string, we need to wrap both masked sOld strings and the sNew strings with the Standard Delimiter constant previously defined:
sOld = kChr & kMsk & lIdx & kMsk & kChr '[kMsk & lIdx & kMsk] is masked sOld
sNew = kChr & aOldNew(lIdx, 2) & kChr
4 - Replace Mask strings with sOld string: Notice that as we wrapped the masked sOld string before replacing when the sOld string was contained in another string it was not replaced as it did not match the wrapped masked sOld string, achieving the expected result. Now we need to replace back the remaining masked sOld strings with the original sOld strings where partial matches within a larger string happened.
5 - Reset the delimiters: Replace the Standard Delimiter Index back to each original delimiter, using the formula mentioned (step 2). This step could also be used to reset the original delimiters to a standard delimiter, however, as the list of delimiters includes the {space} it’s advisable not doing it.
The results returned by the Range_Replace_With_MultiDelimiters procedure mathed the expected results:
Procedures:
Sub Search_and_Replace_Text()
Dim aDelimiters() As Variant
aDelimiters = Array( _
" , ", _
" ,", _
", ", _
",", _
" ")
Dim rTarget As Range, aOldNew() As Variant
Dim sWsh As String, sRng As String, sFml As String
Rem Set array with strings to be replaced (Old\New)
sWsh = "Table2"
sRng = "A:B"
With ThisWorkbook.Worksheets(sWsh).Range(sRng)
Rem Activate target worksheet (needed to apply the Application.Evaluate method)
Application.Goto .Cells(1), 1
With .Cells(2, 1).Resize(-1 + .Cells(.Rows.Count, 1).End(xlUp).Row, 2)
sFml = "=UNIQUE(FILTER(" & .Address _
& ",(" & .Columns(1).Address & "<>TEXT(,))))"
aOldNew = Application.Evaluate(sFml)
End With: End With
Rem Set range to apply the replace method
sWsh = "Table1"
sRng = "H:H"
With ThisWorkbook.Worksheets(sWsh).Range(sRng)
Set rTarget = Range(.Cells(2), .Cells(.Rows.Count).End(xlUp))
End With
Call Range_Replace_With_MultiDelimiters(rTarget, aDelimiters, aOldNew)
End Sub
Private Sub Range_Replace_With_MultiDelimiters( _
ByVal rTarget As Range, aDelimiters() As Variant, aOldNew() As Variant, _
Optional blIncludeFormulas As Boolean)
Rem Uncomment the lines the start with [':]
Rem to have in the Immediate Window a record of each step perfomed by the procedure
Const kChr As String = "§"
Const kMsk As String = "‡"
Dim rArea As Range
Dim sOld As String, sNew As String, lIdx As Long
Dim sFmlA As String, sFmlB As String
Dim sFml As String, aValues As Variant
Rem Built Delimiters Formula - Standardization & Reset
sFmlA = Range_Replace_ƒDelimiters_Formula(aDelimiters, kChr)
sFmlB = Range_Replace_ƒDelimiters_Formula(aDelimiters, kChr, True)
': Debug.Print vbLf; "Built Delimiters Formula - Standardization & Reset"
': Debug.Print "Standardization: "; vbLf; "sFmlA: "; sFmlA
': Debug.Print "Reset: "; vbLf; "sFmlB: "; sFmlB
Rem Exclude Formulas from Target range
If Not (blIncludeFormulas) Then
With rTarget
Set rTarget = Union(.SpecialCells(xlCellTypeBlanks), _
.SpecialCells(xlCellTypeConstants, 23))
End With: End If
With rTarget
Rem Activate target range worksheet (needed to apply the Application.Evaluate method)
Application.Goto .Worksheet.Cells(1), 1
For Each rArea In .Areas
With rArea
Rem Replace Old string To Mask string
': Debug.Print vbLf; "Replace Old To Mask"
': Debug.Print vbTab; "Old"; Tab(21); "New"
For lIdx = 1 To UBound(aOldNew)
sOld = aOldNew(lIdx, 1)
sNew = kMsk & lIdx & kMsk
': Debug.Print vbTab; sOld; Tab(21); sNew
.Replace What:=sOld, Replacement:=sNew, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next
Rem Standardize Delimiters
sFml = Replace(sFmlA, "#RNG", .Address(0, 0))
aValues = Application.Evaluate(sFml)
.Value2 = aValues
': Debug.Print vbLf; "Standardize Delimiters"
': Debug.Print "Fml: "; sFml
Rem Replace Mask string To New string
': Debug.Print vbLf; "Replace Mask To New"
': Debug.Print vbTab; "Old"; Tab(21); "New"
For lIdx = 1 To UBound(aOldNew)
sOld = kChr & kMsk & lIdx & kMsk & kChr
sNew = kChr & aOldNew(lIdx, 2) & kChr
': Debug.Print vbTab; sOld; Tab(21); sNew
.Replace What:=sOld, Replacement:=sNew, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next
Rem Replace Mask string To Old string
': Debug.Print vbLf; "Replace Mask To Old"
': Debug.Print vbTab; "Old"; Tab(21); "New"
For lIdx = 1 To UBound(aOldNew)
sOld = kMsk & lIdx & kMsk
sNew = aOldNew(lIdx, 1)
': Debug.Print vbTab; sOld; Tab(21); sNew
.Replace What:=sOld, Replacement:=sNew, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next
Rem Reset Delimiters
sFml = Replace(sFmlB, "#RNG", .Address(0, 0))
aValues = Application.Evaluate(sFml)
.Value2 = aValues
': Debug.Print vbLf; "Reset Delimiters"
': Debug.Print "Fml: "; sFml
End With: Next: End With
End Sub
Private Function Range_Replace_ƒDelimiters_Formula( _
aDelimiters() As Variant, sChr As String, Optional blReset As Boolean) As String
Dim sOld As String, sNew As String
Dim sFml As String
Dim vItem As Variant, bItem As Byte
Rem Separators
For Each vItem In aDelimiters
Rem Separators Old & New
bItem = 1 + bItem
sOld = IIf(blReset, sChr & bItem & sChr, vItem)
sNew = IIf(blReset, vItem, sChr & bItem & sChr)
Rem Built Formula - Delimiters Array
Select Case bItem
Case 1: sFml = "SUBSTITUTE(#RNG,""" & sOld & """,""" & sNew & """)"
Case Else: sFml = "SUBSTITUTE(" & sFml & ",""" & sOld & """,""" & sNew & """)"
End Select
Next
Rem Built Formula - Delimiters Character
Select Case blReset
Case True: sFml = "=SUBSTITUTE(" & sFml & ",""" & sChr & """,TEXT(,))"
Case Else: sFml = "= """ & sChr & """&" & sFml & "&""" & sChr & """"
End Select
Range_Replace_ƒDelimiters_Formula = sFml
End Function
Using a Macro or Formula, is there a way to achieve the result of the following formula of Office 365?
=FILTER(B:B,A:A = "x")
What it does is get all the values from Column B if Column A on the same row has a value of x.
My PC has office 365 but the one I'm working with only has Office Pro Plus 2019. I had to use my pc when I needed the function and I'm getting tired of it, maybe it can be done on Office Pro Plus 2019 too using a formula or a macro?
Use:
=IFERROR(INDEX($B$1:$B$100,AGGREGATE(15,7,ROW($A$1:$A$100)/($A$1:$A$100="x"),ROW($ZZ1))),"")
Note the use of a set range and not full columns. That is done on purpose, This being an array formula it will do a lot of calculations each cell it is placed. Limiting the range to the data set will speed it up.
Put this in the first cell of the output and copy down till blanks are returned.
I had some spare time and I am recently interested in User defined functions so I decided to make my own version of what I imagine this would be. I'm prefacing this by saying its not good and is excessively long but it works!
Function JOINIF(ByRef IfRange As Range, ByVal Criteria As String, Optional JoinRange As Range, Optional Delimeter As String = ",") As String
'IfRange is the range that will be evaluated by the Criteria
'Criteria is a logical test that can be applied to a cell value.
'Examples of Criteria: "=Steve", ">100", "<>Toronto", "<=-1"
'JoinRange is the range of values that will be concatenated if the corresponding -
'IfRange cell meets the criteria. JoinRange can be left blank if the values to be -
'concatenated are the IfRange values.
'Delimeter is the string that will seperate the concatenated values.
'Default delimeter is a comma.
Dim IfArr() As Variant, JoinArr() As Variant, OutputArr() As String
Dim IfArrDim As Integer, JoinArrDim As Integer
Dim JCount As Long, LoopEnd(1 To 2) As Long
Dim MeetsCriteria As Boolean, Expression As String
Dim i As Long, j As Long
'PARSING THE CRITERIA
Dim Regex As Object
Set Regex = CreateObject("VBScript.RegExp")
Regex.Pattern = "[=<>]+"
'Looking for comparison operators
Dim Matches As Object
Set Matches = Regex.Execute(Criteria)
If Matches.Count = 0 Then
'If no operators found, assume default "Equal to"
If Not IsNumeric(Criteria) Then
'Add quotation marks to allow string comparisons
Criteria = "=""" & Criteria & """"
End If
Else
If Not IsNumeric(Replace(Criteria, Matches(0), "")) Then
Criteria = Matches(0) & """" & Replace(Criteria, Matches(0), "") & """"
End If
'Add quotation marks to allow string comparisons
End If
'Trim IfRange to UsedRange
Set IfRange = Intersect(IfRange, IfRange.Parent.UsedRange)
'Default option for optional JoinRange input
If JoinRange Is Nothing Then
Set JoinRange = IfRange
Else
Set JoinRange = Intersect(JoinRange, JoinRange.Parent.UsedRange)
End If
'DIMENSIONS
'Filling the arrays
If IfRange.Cells.Count > 1 Then
IfArr = IfRange.Value
IfArrDim = Dimensions(IfArr)
Else
ReDim IfArr(1 To 1)
IfArr(1) = IfRange.Value
IfArrDim = 1
End If
If JoinRange.Cells.Count > 1 Then
JoinArr = JoinRange.Value
JoinArrDim = Dimensions(JoinArr)
Else
ReDim JoinArr(1 To 1)
JoinArr(1) = JoinRange.Value
JoinArrDim = 1
End If
'Initialize the Output array to the smaller of the two input arrays.
ReDim OutputArr(IIf(IfRange.Cells.Count < JoinRange.Cells.Count, IfRange.Cells.Count - 1, JoinRange.Cells.Count - 1))
'DEFINING THE LOOP PARAMETERS
'Loop ends on the smaller of the two arrays
If UBound(IfArr) > UBound(JoinArr) Then
LoopEnd(1) = UBound(JoinArr)
Else
LoopEnd(1) = UBound(IfArr)
End If
If IfArrDim = 2 Or JoinArrDim = 2 Then
If Not (IfArrDim = 2 And JoinArrDim = 2) Then
'mismatched dimensions
LoopEnd(2) = 1
ElseIf UBound(IfArr, 2) > UBound(JoinArr, 2) Then
LoopEnd(2) = UBound(JoinArr, 2)
Else
LoopEnd(2) = UBound(IfArr, 2)
End If
End If
'START LOOP
If IfArrDim = 1 Then
For i = 1 To LoopEnd(1)
If IsNumeric(IfArr(i)) And IfArr(i) <> "" Then
Expression = IfArr(i) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, 1))
End If
JCount = JCount + 1
End If
Next i
Else
For i = 1 To LoopEnd(1)
For j = 1 To LoopEnd(2)
If IsNumeric(IfArr(i, j)) And IfArr(i, j) <> "" Then
Expression = IfArr(i, j) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i, j) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, j))
End If
JCount = JCount + 1
End If
Next j
Next i
End If
'END LOOP
ReDim Preserve OutputArr(JCount + 1 * (JCount > 0))
JOINIF = Join(OutputArr, Delimeter)
End Function
Private Function Dimensions(var As Variant) As Long
'Credit goes to the great Chip Pearson, chip#cpearson.com, www.cpearson.com
On Error GoTo Err
Dim i As Long, tmp As Long
While True
i = i + 1
tmp = UBound(var, i)
Wend
Err:
Dimensions = i - 1
End Function
Examples of it in use:
Seperate IfRange and JoinRange
IfRange as the JoinRange
You might try the following udf (example call: FILTER2(A1:A100,B1:B100)) consisting of the following tricky steps:
a) Evaluate the general condition (=If(A1:A100="x",Row(A1:A100),"?") as tabular Excel formula and assign all valid row numbers to array x (marking the rest by "?" strings),
b) Filter out all "?" elements
c) Apply x upon the data column benefitting from the advanced restructuring features of Application.Index()
Public Function Filter2(rng1 As Range, rng2 As Variant, Optional ByVal FilterID As String = "x")
Dim a As String: a = rng1.Address(False, False, External:=True)
'a) get all valid row numbers (rng1)
Dim myformula As String: myformula = "if(" & a & "=""" & FilterID & """,row(" & a & "),""?"")"
Dim x: x = Application.Transpose(Evaluate(myformula))
'b) filter out invalid "?" elements
x = VBA.Filter(x, "?", False)
'c) apply x upon data column (rng2)
If UBound(x) > -1 Then Filter2 = Application.Index(rng2, Application.Transpose(x), 1)
End Function
Note that function calls before versions 2019/MS 365 need to be entered as array formula (Ctrl+Shift+Enter).
The function assumes one-column (range) arguments.
Edit due to comment as of 2022-06-08
The whole example is based on the actual row numbers starting in the first row (OP ranges refer to A:A,B:B. If you want to allow ranges to start at any row, you'd need to change the myFormula definition in section a) by correcting the row indices by subtracting possible offsets (row number + 1 - first row):
Dim myFormula As String
myFormula = "if(" & a & "=""" & FilterID & """,row(" & a & ")+1 -" & rng1.Row & ",""?"")"
Try this UDF for the Filter Function:
Function FILTER_HA(Where, Criteria, Optional If_Empty) As Variant
Dim Data, Result
Dim i As Long, j As Long, k As Long
'Create space for the output (same size as input cells)
With Application.Caller
i = .Rows.Count
j = .Columns.Count
End With
'Clear
ReDim Result(1 To i, 1 To j)
For i = 1 To UBound(Result)
For j = 1 To UBound(Result, 2)
Result(i, j) = ""
Next
Next
'Count the rows to show
For i = 1 To UBound(Criteria)
If Criteria(i, 1) Then j = j + 1
Next
'Empty?
If j < 1 Then
If IsMissing(If_Empty) Then
Result(1, 1) = CVErr(xlErrNull)
Else
Result(1, 1) = If_Empty
End If
GoTo ExitPoint
End If
'Get all data
Data = Where.Value
'Copy the rows to show
For i = 1 To UBound(Data)
If Criteria(i, 1) Then
k = k + 1
For j = 1 To UBound(Data, 2)
Result(k, j) = Data(i, j)
Next
End If
Next
'Return the result
ExitPoint:
FILTER_HA = Result
End Function
I have been trying to Concatenate two Columns directly from the Table1. But i really do not know how. I have tried and make below code.
But I have been creating first 2 helping Column in in "DI" and "DJ" to make this thing work.
I do not want to use these two helping columns directly wants the concatenate result in "DK2"
All help will be appreciaed.
Dim O As String
Dim P As String
O = "Milestone"
P = "Task"
Sheet1.Range("Table1[" & O & "]").Copy
Sheet2.Range("DI2").PasteSpecial xlPasteValues
Sheet1.Range("Table1[" & P & "]").Copy
Sheet2.Range("DJ2").PasteSpecial xlPasteValues
For i = 2 To Cells(Rows.Count, "DH").End(xlUp).Row
Sheet2.Cells(i, "DK").Value = Sheet2.Cells(i, "DI").Value & "" & Sheet2.Cells(i, "DJ").Value
Next i
Here is the example Picture
Try this.
Range("DK2").Resize(Sheet2.ListObjects("Table1").ListRows.Count) = Application.Evaluate("Table1[Milestone]&Table1[Task]")
EDIT: I've seen #norie's answer and it is simpler and more efficient than mine. I'll keep my answer here for anyone who is curious, but I recommend using his solution.
The trick is to use =INDEX(YOUR_TABLE[YOUR_COLUMN]], YOUR_ROW_STARTING_FROM_1) in order to obtain the cell contents that you needed.
Here you are your code edited:
Original
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
Optimized
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using only Formulas (this performs better that the others)
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using Formulas and then converting back to values
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
' Convert from formulas to values
Range("DK:DK").Copy
Range("DK:DK").PasteSpecial xlPasteValues
This can be done directly in the worksheet by using the Index function
Reference first cell in the table: =INDEX(Table1,1,1)
Concatenate cell 1 and 2 values: =INDEX(Table1,1,1)&INDEX(Table1,1,2)
It gets slightly more complicated if you want to be able to copy formulae across or down as you need to reference the current cell location
Reference first cell in the table using offsets: =INDEX(Table1,ROW()-X,COLUMN()-Y) where X, Y (minus data location offsets) are the numerical row/column of the cell where you have placed the formula.
i.e. if placing the formula in E2 to reference Table1 cell(1,1) => =INDEX(Table1,ROW()-1,COLUMN()-4)
where Column E=> Offset 4, Row 2 => Offset 1
or: =INDEX(Table1,ROW()-ROW($E$2)+1,COLUMN()-COLUMN($E$2)+1)
You can now autofill the formula down or across
Concatenate List Columns
With your amount of data both solutions may seem equally efficient. I've tested it with a million rows of random numbers from 1 to 1000, and the first solution took about 3.5 seconds, while the second took about 5.5 seconds on my machine. The first solution is just a more elaborate version of norie's answer.
In this solution, you can add more columns (headers) and use a delimiter. While adding more columns the difference in the efficiencies will become more apparent, while when adding more characters to the delimiter, the efficiencies will decrease seemingly equally.
The Code
Option Explicit
Sub concatListColumnsEvaluate()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Determine table rows count.
Dim rCount As Long: rCount = Sheet1.ListObjects(TableName).ListRows.Count
' Create Evaluate Expression String.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim evString As String
Dim t As Long
If Len(Delimiter) = 0 Then
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&"
Next t
evString = Left(evString, Len(evString) - 1)
Else
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&""" _
& Delimiter & """&"
Next t
evString = Left(evString, Len(evString) - Len(Delimiter) - 4)
End If
' Write values to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Application.Evaluate(evString)
Debug.Print Timer - dTime
End Sub
Sub concatListColumnsArrays()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Write values from list columns to arrays of Data Array.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim Data As Variant: ReDim Data(0 To tUpper)
Dim t As Long
For t = 0 To tUpper
' Either...
Data(t) = Sheet1.Range(TableName & "[" & Headers(t) & "]").Value
' ... or:
'Data(t) = Sheet1.ListObjects(TableName) _
.ListColumns(Headers(t)).DataBodyRange.Value
Next t
' Concatenate values of arrays of Data Array in Result Array.
Dim rCount As Long: rCount = UBound(Data(0), 1)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long
If Len(Delimiter) = 0 Then
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1)
Next t
Next r
Else
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1) & Delimiter
Next t
Result(r, 1) = Left(Result(r, 1), Len(Result(r, 1)) _
- Len(Delimiter))
Next r
End If
' Write values from Result Array to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Result
Debug.Print Timer - dTime
End Sub
I have an excel sheet that has cells with variable amounts of line breaks and I want to reduce it so that there is only one line break between each new line.
For example
HELLO
WORLD
GOODBYE
will be modified to:
HELLO
WORLD
GOODBYE
I've been banging my head over this for hours and have come up with a few ways but none are very efficient or produce the best results.
This is made especially difficult because I'm working with a dataset that has spaces preceeding the Line Breaks.
And so a regular parse doesn't work as well.
I've tried to replace all the instances of chr(10) in the cell with ~ to make it easier to work with, however i'm still not getting it to an exact amount. I'm wondering if there are better ways.
here is what I have so far:
myString = Replace(myString, Chr(10), "~")
Do While InStr(myString, "~~") > 0
str1 = Split(myString, "~")
For k = 0 To UBound(str1)
myString = Replace(myString, "~~", "~")
Next k
Loop
Do While InStr(myString, " ~") > 0
str1 = Split(myString, "~")
For k = 0 To UBound(str1)
myString = Replace(myString, " ~", "")
Next k
Loop
myString = Replace(myString, " ~", " ~")
myString = Replace(myString, " ~", "~")
myString = Replace(myString, "~", Chr(10))
Cells(2, 2).Value = myString
So i'm using a few do while loops to catch instances of different types of line breaks (or in this case, tildes) but I don't think this is the best way to tackle this.
I was thinking of ways to loop through the characters in the cell, and if there is an instance where there is more than one chr(10), replace it with "".
So the psuedocode would look like:
for i to len(mystring)
if mystring(i) = chr(10) AND myString(i+1) = chr(10) Then
myString(i + 1) = ""
but unfortunately I don't think this is possible through vba.
If anyone is kind enough to help me adjust my current code or assist me with the aforementioned psuedocode, it would be greatly appreciated!
You can do it with a formula:
=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(TRIM(A1)," ","|"),"|"&CHAR(10)," "),CHAR(10)," "))," ",CHAR(10)),"|"," ")
This changes all the spaces to | and then the Char(10) to spaces. The trim removes the extra spaces. The we reverse, space to Char(10) and | to spaces.
VBA:
Function manytoone(str As String)
str = Replace(Application.Trim(str), " ", "|")
str = Replace(str, "|" & Chr(10), " ")
str = Replace(str, Chr(10), " ")
str = Application.Trim(str)
str = Replace(str, " ", Chr(10))
str = Replace(str, "|", " ")
manytoone = str
End Function
You can use Regular Expressions.
The regex pattern below removes any line that contains zero to any number of spaces, along with its terminating crlf, and also removes the crlf at the end of the final word.
Option Explicit
Sub trimXSLF()
Dim myRng As Range, myCell As Range, WS As Worksheet
Dim RE As Object
Const sPat As String = "^\s*[\x0A\x0D]+|[\x0A\x0D](?!\s*\S+\s*)"
Const sRepl As String = ""
Set WS = Worksheets("sheet4") 'or whatever
With WS
Set myRng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.MultiLine = True
.Pattern = sPat
For Each myCell In myRng
myCell = .Replace(myCell.Value2, sRepl)
Next myCell
End With
End Sub
If myRng is large (tens of thousands of rows), the macro could run the process over a VBA array for speed.
A VBA method would be replacing consecutive vbLf constants with a single one.
Loop through the string as long as there are more than one vbLf together, once removed, replace the string.
Sub RemoveExcessLinebreaks()
Dim s As String, rng As Range
Set rng = ThisWorkbook.Worksheets(1).Range("B4")
s = rng.Value
While InStr(1, s, vbLf & vbLf) > 0
s = Replace(s, vbLf & vbLf, vbLf)
Wend
rng.Value = s
End Sub
Obviously, you would need to modify the rng object to your purposes, or turn it into a parameter to the sub itself.
vbLf is a constant for a "LineFeed". There are multiple types of new lines, such as a vbCr (Carriage Return) or a vbCrLf (combined). Pressing Alt + Enter in a cell appears to use the vbLf variant, which is why I used this constant over the others.
This has already been answered fairly well, but not meeting one of the requirements yet (have 1 line between each new line), so here is my take on answering this. Please see the comments through the code for more details:
Option Explicit
Sub reduceNewLines()
Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("Sheet1")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim lCol As Long: lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim arrData As Variant: arrData = ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol))
Dim arrVal() As String
Dim R As Long, C As Long, X As Long
For R = LBound(arrData) To UBound(arrData) 'Iterate through each row of data
For C = LBound(arrData, 2) To UBound(arrData, 2) 'iterate through each column of data (though might be just 1)
arrVal = Split(arrData(R, C), Chr(10)) 'allocate each row to an array, split at new line
arrData(R, C) = "" 'reset the data inside this field
For X = LBound(arrVal) To UBound(arrVal)
arrVal(X) = Trim(arrVal(X)) 'clear leading/trailing spaces
If Left(arrVal(X), 1) <> " " And arrVal(X) <> "" Then
arrData(R, C) = arrData(R, C) & arrVal(X) & Chr(10) & Chr(10) 'allocate new data + 2 lines
End If
Next X
arrData(R, C) = Left(arrData(R, C), Len(arrData(R, C)) - 2) 'remove the last 2 extra new lines
Next C
Next R
ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol)) = arrData 'allocate the data back to the sheet
End Sub
Happy to assist further if needed.