Related
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.
Hello and thanks in advance for any assistance. I have a work sheet with two tabs named DATA PULL and LIST. The LIST tab contains a list of keywords (250 words) in column A. I need to search for those key words in columns P and Q on the DATA PULL tab and return any matches to column I(the data is in a table). Columns P and Q contain multiple words or sentences.
The code below does what I need but the list of key words is on the same sheet. This code also deletes letters from my table headers for some reason.
Sub GetWords()
Dim wrdLRow As Integer
Dim wrdLp As Integer
Dim CommentLrow As Integer
Dim CommentLp As Integer
Dim fndWord As Integer
Dim Sht As Worksheet
On Error Resume Next 'Suppress Errors... for when we don't find a match
'Define worksheet that has data on it....
Set Sht = Sheets("DATA PULL")
'Get last row for words based on column A
wrdLRow = Sht.Cells(Rows.Count, "A").End(xlUp).Row
'Get last row for comments based on column C
CommentLrow = Sht.Cells(Rows.Count, "P").End(xlUp).Row
'Loop through lists and find matches....
For CommentLp = 2 To CommentLrow
For wrdLp = 2 To wrdLRow
'Look for word...
fndWord = Application.WorksheetFunction.Search(Sht.Cells(wrdLp, "A"), Sht.Cells(CommentLp, "P"))
'If we found the word....then
If fndWord > 0 Then
Sht.Cells(CommentLp, "I") = Sht.Cells(CommentLp, "I") & "; " & Sht.Cells(wrdLp, "A")
fndWord = 0 'Reset Variable for next loop
End If
Next wrdLp
Sht.Cells(CommentLp, "I") = Mid(Sht.Cells(CommentLp, "I"), 3, Len(Sht.Cells(CommentLp, "I")) - 2)
Next CommentLp
End Sub
Any help is greatly appreciated.
LIST
DATAPULL
Some tips for your code:
Using a
On error Resume Next
like you are using is a bad practice and can result in trouble. You might have other errors that won't show up because of that, and this will prevent you from debugging them and finding the problem. I would recommend using it only before the problematic line, and after that using
On Error goto 0
to resume showing and finding other possible errors.
A way of totally avoiding having to use "On Error Resume Next" is using the "Like" Operator. If you use
If Sht.Cells(CommentLp, "P") Like "*" & Sht.Cells(wrdLp, "A") & "*" Then
Sht.Cells(CommentLp, "I") = Sht.Cells(CommentLp, "I") & "; " & Sht.Cells(wrdLp, "A")
End If
You can do the same thing without worrying about errors. Basically, "Like" does a search to see if a text looks like the other. The two "*" means any kind and number of characters, so all together means that Sht.Cells(CommentLp, "P") must be like: any kind and number of characters, followed by the value of Sht.Cells(wrdLp, "A"), followed by any kind or number of characters. Just like "Search" =) !
Doing this change also forced me to adapt the way you are dealing with the starting "; " in your code, but also for a better way:
Dim wrdLRow As Integer
Dim wrdLp As Integer
Dim CommentLrow As Integer
Dim CommentLp As Integer
Dim fndWord As Integer
Dim DataSht As Worksheet
Dim ListSht as Worksheet
'Define the worksheets
Set DataSht = Sheets("DATA PULL")
Set ListSht = Sheets("LIST")
'Get last row for words based on column A
wrdLRow = ListSht.Cells(Rows.Count, "A").End(xlUp).Row
'Get last row for comments based on column C
CommentLrow = DataSht.Cells(Rows.Count, "P").End(xlUp).Row
For CommentLp = 2 To CommentLrow
For wrdLp = 2 To wrdLRow
If LCASE(DataSht.Cells(CommentLp, "P")) Like "*" & LCASE(ListSht.Cells(wrdLp, "A")) & "*" Then
If DataSht.Cells(CommentLp, "I") <> "" Then
DataSht.Cells(CommentLp, "I") = DataSht.Cells(CommentLp, "I") & "; " & ListSht.Cells(wrdLp, "A")
Else
DataSht.Cells(CommentLp, "I") = ListSht.Cells(wrdLp, "A")
End If
ElseIf LCASE(Sht.Cells(CommentLp, "Q")) Like "*" & LCASE(Sht.Cells(wrdLp, "A")) & "*" Then
If NewSht.Cells(writeRow, "A") <> "" Then
NewSht.Cells(writeRow, "A") = NewSht.Cells(writeRow, "A") & "; " & Sht.Cells(wrdLp, "A")
Else
NewSht.Cells(writeRow, "A") = Sht.Cells(wrdLp, "A")
End If
End If
Next wrdLp
Next CommentLp
This code runs for me without a problem, but so did yours. I am assuming you didn't share your whole code, also because you mentioned two columns and only wrote the code for one. I think the problem might be in the part you didn't share, and perhaps this modification I wrote, without the "On Error Resume Next", you help you find it!
I just hoped I didn't get confused with the variables and list, but I think now you can have a good idea of what I am doing. Hope it helps.
I think you could try this:
EDITED VERSION:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LRA As Long, i As Long, LRP As Long, LRQ As Long, LRI As Long
Dim SearchingValue As String
Dim rng As Range, cell As Range
With ThisWorkbook
Set ws1 = .Worksheets("DATA PULL")
Set ws2 = .Worksheets("LIST")
With ws1
LRP = .Cells(.Rows.Count, "P").End(xlUp).Row
LRQ = .Cells(.Rows.Count, "Q").End(xlUp).Row
Set rng = .Range("P1:P" & LRP, "Q1:Q" & LRQ)
End With
With ws2
LRA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LRA
SearchingValue = .Range("A" & i).Value
For Each cell In rng
If InStr(1, cell.Value, SearchingValue) > 0 Then
With ws1
LRI = .Cells(.Rows.Count, "I").End(xlUp).Row
.Range("I" & LRI + 1).Value = "Value " & """" & .Range("A" & i).Value & """" & " appears in sheet DATA PULL, " & "column " & cell.Column & ", row " & cell.Row & "."
Exit For
End With
End If
Next cell
Next i
End With
End With
End Sub
I have an excel file that has some cells with several text in parenthesis and outside parenthesis. I would like to split the cells. For example , I have some cells appearing like this
(some text in) parenthesis and (others outside)
I would to split the cells so that the some text in is in a different cell, parenthesis and also in a different cell and others outside also in a different cell. What I have so far only splits what's in parenthesis. Thanks in advance. Here's my code below
Sub StripCells()
Dim r As Range, i As Long
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\(([^\)]+)\)"
For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
If .test(r.Value) Then
For i = 0 To .Execute(r.Value).Count - 1
r(, i + 2).Value = "'" & .Execute(r.Value)(i).submatches(0)
Next
End If
Next
End With
End Sub
If all your cells begin with an " ( " then:
Sub fracture()
Dim r As Range, a, arr, i As Long
For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
arr = Split(Replace(r.Value, "(", ")"), ")")
i = 0
For Each a In arr
If i <> 0 Then
r.Offset(0, i).Value = a
End If
i = i + 1
Next a
Next r
End Sub
I found a pattern that works. (I cheat, and use Replace(), but it seems to do the trick):
Sub StripCells()
Dim r As Range, i As Long
With CreateObject("VBScript.RegExp")
.Global = True
'.Pattern = "\(([^\)]+)\)"
.Pattern = "((\(([^\)]+)\))|[\w+ ]+)"
For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
If .test(r.Value) Then
For i = 0 To .Execute(r.Value).Count - 1
r(, i + 2).Value = "'" & Replace(Replace(.Execute(r.Value)(i).submatches(0), ")", ""), "(", "")
Next
End If
Next
End With
End Sub
I'm creating a Macro to do almost exactly what is outlined here:
Excel/Categorization Macro(formula) based on string of text containing keywords
My question is that in the code from the example above Like "" is used to check to see if the Description matches a keyword and if it does then it pulls the corresponding category name. In my case, I don't currently have keywords for every possible category (but will eventually have them as I collect more transaction data), meaning some of the cells in my keyword column are blank and the way the above code is written it considers patternfound = true when it encounters an empty cell. How do I alter the If statement with "Like" or something similar so that it skips over a cell if it's completely blank and only provides a match when there are some characters (that match) in the cell?
I've found a work around by putting "N/A" in the empty cells but I'd rather not do that. Here is my code:
Sub Categorize()
Dim lastrow As Long, lastrow2 As Long
Dim i As Integer, j As Integer
Dim PatternFound As Boolean
Call speedup
lastrow = Sheets("Categorization").Range("B" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("Cleaned Spend Data").Range("C" & Rows.Count).End(xlUp).Row
For i = 4 To lastrow2
PatternFound = False
j = 1
Do While PatternFound = False And j < lastrow
j = j + 1
If UCase(Sheets("Cleaned Spend Data").Range("B" & i).Value) Like "*" & UCase(Sheets("Categorization").Range("B" & j).Value) & "*" Then
Sheets("Cleaned Spend Data").Range("D" & i).Value = Sheets("Categorization").Range("A" & j).Value
PatternFound = True
End If
Loop
Next i
Call normal
End Sub
Thanks!
You can test for an empty cell...
Also - your code could be cleaner using a couple of variables for your worksheets.
Sub Categorize()
Dim lastrow As Long, lastrow2 As Long
Dim i As Integer, j As Integer
Dim PatternFound As Boolean, shtCat As Worksheet, shtCleaned As Worksheet
Dim v, t
Set shtCat = Sheets("Categorization")
Set shtCleaned = Sheets("Cleaned Spend Data")
Call speedup
lastrow = shtCat.Range("B" & Rows.Count).End(xlUp).Row
lastrow2 = shtCleaned.Range("C" & Rows.Count).End(xlUp).Row
For i = 4 To lastrow2
v = UCase(UCase(shtCleaned.Range("B" & i).Value))
For j = 1 To lastrow
t = UCase(Sheets("Categorization").Range("B" & j).Value)
If Len(t) > 0 And v Like "*" & t & "*" Then
shtCleaned.Range("D" & i).Value = shtCat.Range("A" & j).Value
Exit For
End If
Next j
Next i
Call normal
End Sub
I'm trying to create a simple translation script that will look at a sentence in each cell from a range (column), and translate word by word based on the simple two-column (lookat/replace) translation memory I've created.
If the cell contains
"This app is cool"
and the translation memory is
This | 1
app | 2
cool | 3
Result should be:
"1 2 is 3"
However, using .Replace method, The below string:
"This apple from the cooler"
Would return
"1 2le from the 3er"
I used an array and split method to break the sentence into words, and then looked up at each words from my translation list for a xlwhole match. I have about 10,000 lines of sentences, and to break down each sentence into words would be roughly about 100,000 words and each word looking through about 1,000 list of translation words. It words.. but kind of slow.
Are there any other way, perhaps a better approach?
Here's another regex solution using the replace method and word boundaries (the "\b" in the regex pattern represents a word boundary). It assumes your source is in column A, and the results will go into column B.
The translation table is hard coded in the macro, but you could easily change that to be picked up from a table in your workbook.
Option Explicit
Sub Translate()
Dim V As Variant
Dim RE As Object
Dim arrTranslate As Variant
Dim I As Long, J As Long
Dim S As String
V = Range("a1", Cells(Rows.Count, "A").End(xlUp))
ReDim Preserve V(1 To UBound(V, 1), 1 To 2)
arrTranslate = VBA.Array(Array("This", 1), Array("app", 2), Array("cool", 3))
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.ignorecase = True
End With
For I = 1 To UBound(V, 1)
S = V(I, 1)
For J = 0 To UBound(arrTranslate)
RE.Pattern = "\b" & arrTranslate(J)(0) & "\b"
S = RE.Replace(S, arrTranslate(J)(1))
Next J
V(I, 2) = S
Next I
Range(Cells(1, 1), Cells(UBound(V, 1), UBound(V, 2))) = V
End Sub
Word to the rescue: Here I make use of of the "Match whole words only" option in Word's Find/Replace functionality.
Dim rngSentences As Range
Dim sentences, translatedSentences, wordsToReplace, newStrings
Dim iWord As Long
Dim iSentence As Long
Dim cell As Range
Dim w As Word.Application
Dim d As Word.Document
Set rngSentences = Range("A1:A5")
wordsToReplace = Array("this", "app", "cool")
newStrings = Array("1", "2", "3")
Set w = New Word.Application
Set d = w.Documents.Add(DocumentType:=wdNewBlankDocument)
sentences = rngSentences.Value ' read sentences from sheet
ReDim translatedSentences(LBound(sentences, 1) To UBound(sentences, 1), _
LBound(sentences, 2) To UBound(sentences, 2))
For iSentence = LBound(sentences, 1) To UBound(sentences, 1)
'Put sentence in Word document
d.Range.Text = sentences(iSentence, 1)
'Replace the words
For iWord = LBound(wordsToReplace) To UBound(wordsToReplace)
d.Range.Find.Execute Findtext:=wordsToReplace(iWord), _
Replacewith:=newStrings(iWord), MatchWholeWord:=True
Next iWord
'Grab sentence back from Word doc
translatedSentences(iSentence, 1) = d.Range.Text
Next iSentence
'slap translated sentences onto sheet
rngSentences.Offset(0, 1) = translatedSentences
w.Quit savechanges:=False
Another, potentially faster alternative is to paste all your sentences into the Word doc at once, replace everything, then copy-paste everything back to Excel sheet at once. It may be faster; I don't know, I haven't tested it extensively; up to you to do so.
To implement this, the lines after Set d = ... can be replaced with this:
'Copy-paste all sentences into Word doc
rngSentences.Copy
d.Range.PasteSpecial DataType:=wdPasteText
'Replace words
For iWord = LBound(wordsToReplace) To UBound(wordsToReplace)
d.Range.Find.Execute Findtext:=wordsToReplace(iWord), Replacewith:=newStrings(iWord), _
MatchWholeWord:=True
Next iWord
'Copy-paste back to Excel sheet
d.Range.Copy
rngSentences.Offset(0, 1).PasteSpecial xlPasteValues
w.Quit savechanges:=False
If you want you can use Regex.
Following the Scheme:
The Code:
' reference: "Microsoft VBScript Regular Expressions 5.5"
Dim RegX As Object, Mats As Object, Counter As Long
Set RegX = CreateObject("VBScript.RegExp")
Dim TrA(1 To 1000) As String
Dim TrB(1 To 1000) As String
Dim TrMax As Integer
Dim StrSp
For i = 1 To 9999
If Range("D" & i).Value = "" Then Exit For
TrA(i) = Range("D" & i).Value
TrB(i) = Range("E" & i).Value
TrMax = i
Next
Range("B1:B10").ClearContents
For i = 1 To 9999
If Range("A" & i).Value = "" Then Exit For
With RegX
.Global = True
.Pattern = "[a-zA-Z0-9]+"
Set Mats = .Execute(Range("A" & i).Value)
End With
kk = Range("A" & i).Value
For Counter = 0 To Mats.Count - 1
For e = 1 To TrMax
If LCase(Mats(Counter)) = TrA(e) Then
kk = Replace(kk, Mats(Counter), TrB(e), , 1)
End If
Next
Next
Range("B" & i).Value = kk
Next
Set Mats = Nothing
Set RegX = Nothing
Regex it's quickly, but the Word code it's very interesting (Copy & Paste ... :-)