Related
I want to trim a string in MS Excel each cell to 100 characters in a column with 500 cells.
Starting with first cell, check if string length is or equal 100 characters. If the words are more than 100, then remove 1 word in the cell, then check again, if it's more than 100 remove another word until the string is less to 100. Then paste the less than 100 character string into the same cell replacing previous more than 100 character string.
Then move to another cell and replete the previous step.
The words to be removed are in an array
Here is my code so far
Sub RemoveWords()
Dim i As Long
Dim cellValue As String
Dim stringLenth As Long
Dim myString As String
Dim words() As Variant
words = Array("Many", "specific ", "Huawei", "tend", "Motorolla", "Apple")
myString = "Biggest problem with many phone reviews from non-tech specific publications is that its reviewers tend to judge the phones in a vacuum"
For i = 1 To 13
cellValue = Cells(i, 4).Value
If Not IsEmpty(cellValue) Then
stringLength = Len(cellValue)
' test if string is less than 100
If stringLength > 100 Then
Call replaceWords(cellValue, stringLength, words)
Else
' MsgBox "less than 100 "
End If
End If
Next i
End Sub
Public Sub replaceWords(cellValue, stringLength, words)
Dim wordToRemove As Variant
Dim i As Long
Dim endString As String
Dim cellPosition As Variant
i = 0
If stringLength > 100 Then
For Each wordToRemove In words
If InStr(1, UCase(cellValue), UCase(wordToRemove )) = 1 Then
MsgBox "worked word found" & " -- " & cellValue & " -- " & key
Else
Debug.Print "Nothing worked" & " -- " & cellValue & " -- " & key
End If
Next wordToRemove
Else
MsgBox "less than 100 "
End If
End Sub
Sub NonKeyWords()
' remove non key words
'
Dim i As Long
Dim cellValue As String
Dim stringLenth As Long
Dim wordToRemove As Variant
Dim words() As Variant
Dim item As Variant
' assign non-key words to array
words = words = Array("Many", "specific ", "Huawei", "tend", "Motorolla", "Apple")
' loop though all cells in column D
For i = 2 To 2000
cellValue = Cells(i, 4).Value
If Not IsEmpty(cellValue) Then
' test if string is less than 100
If Len(cellValue) > 100 Then
'Debug.Print "BEFORE REMOVING: " & cellValue
Call replaceWords(cellValue, words, i)
Else
' MsgBox "less than 100"
End If
End If
Next i
End Sub
Public Sub replaceWords(cellValue, words, i)
If Len(cellValue) > 100 Then
For Each wordsToDelete In words
If Len(cellValue) > 100 Then
cellValue = Replace(cellValue, wordsToDelete, "")
'Debug.Print cellValue
Debug.Print "String length after removal = " & Len(cellValue)
Debug.Print "remove another word................"
'cells(i, 4).ClearContents
Cells(i, 4).Value = cellValue
Else
'exit
End If
Next
Else
Debug.Print "SAVE: " & cellValue
End If
End Sub
Why is my first iteration in Sub throughCols that is intended to move one row down each time jumping four rows?
Option Explicit
Dim txt As String
Dim i As Long
Dim strTest As String
Dim strArray() As String
Dim lCaseOn As Boolean
Dim firstRow As Long, startIt As Long
Dim thisCell As Range
Dim lastRow As Long
Dim resetAddress As Range
Sub throughCols()
' Dim thisCell As Range
' get start and end of column data
' NB sheet name is hard coded twice
Call dataRange
startIt = firstRow + 1
For i = 1 To 8 Step 1
' after testing use startIt To lastRow Step 1
' by using activeCell I dont have to pass range through to the sub
Sheets("test").Range("B" & i).Select
MsgBox "this is itteration " & i & " which will output to " & ActiveCell.Offset(0, 2).Address
Call arrayManip
Call cleanTxt(txt)
Next i
End Sub
Sub arrayManip()
' clear out all data
Erase strArray
txt = ""
'set default case
lCaseOn = False
' string into an array using a " " separator
strTest = WorksheetFunction.Proper(ActiveCell.Value)
strTest = Replace(strTest, "-", " - ")
strTest = Replace(strTest, "‘", " ‘ ")
strArray = Split(strTest, " ")
' itterate through array looking to make text formats
For i = LBound(strArray) To UBound(strArray)
If strArray(i) = "-" Then
lCaseOn = True
GoTo NextIteration
End If
If strArray(i) = "‘" Then
lCaseOn = True
GoTo NextIteration
End If
If lCaseOn Then
strArray(i) = LCase(strArray(i))
lCaseOn = False
NextIteration:
End If
Next
End Sub
Function cleanTxt(txt)
' loop through the array to build up a text string
For i = LBound(strArray) To UBound(strArray)
txt = txt & strArray(i) & " "
Next i
' remove the space
txt = Trim(Replace(txt, " - ", "-"))
txt = Trim(Replace(txt, " ‘ ", "‘"))
' MsgBox "active cell is " & activeCell.Address
ActiveCell.Offset(0, 2).Select: ActiveCell.Value = txt
' MsgBox "final output would be " & txt & " to " & activeCell.Address
' this is a thumb suck to attempt to reset the active cell to the itteration address that started it
ActiveCell.Offset(0, -2).Select
MsgBox "next itteration should start with active cell set as " & ActiveCell.Address
End Function
Sub dataRange()
With Sheets("test").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then '<--| if no data whatever
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants) '<--| reference its cells with constant (i.e, not derived from formulas) values)
firstRow = .Areas(1).Row
lastRow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
' MsgBox "the first row is " & firstRow
' MsgBox "last row is " & lastRow
End If
End With
End Sub
You are declaring your i variable at module scope, which makes it accessible everywhere within the module; it's modified when you call arrayManip and the value changes.
If you declare a local ind variable inside this routine it won't happen, because the variable will only be accessible to the scope it's declared in. Try the code below:
Sub throughCols()
' Dim thisCell As Range
Dim ind As Long '<-- DECLARE local variable
' get start and end of column data
' NB sheet name is hard coded twice
Call dataRange
startIt = firstRow + 1
' ===== loop on ind and not i (changes when you call arrayManip) ====
For ind = 1 To 8 ' Step 1 <-- actually not needed, that's the default increment value
' after testing use startIt To lastRow Step 1
' by using activeCell I dont have to pass range through to the sub
Sheets("test").Range("B" & ind).Select
MsgBox "this is itteration " & ind & " which will output to " & ActiveCell.Offset(0, 2).Address
Call arrayManip
Call cleanTxt(txt)
Next ind
End Sub
I currently have a VBA sub routine in an Excel sheet that prompts the user with an input box, inserts the data into a cell, and automatically advances to the cell below if the entire string will not fit into a single cell. It works, but the code will advance to the next line even if it has to split a word to do it. I do not want this, and I would appreciate some suggestions on how to improve my code so that Excel not only advances cells, but advances cells with words that don't get cut off.
Sub AutoCellAdvance()
If bolEditMode = True Then
Exit Sub
End If
Dim str As String, x As Integer, y As Integer
intPlaceholder = Sheet1.Range("AE1").Value
If IsEmpty(ActiveCell) Then
str = InputBox("Enter Description of Activities (Max 192 characters)", "Incidents, Messages, Orders, Etc.")
y = 0
For x = 1 To Len(str) Step 64
ActiveCell.Offset(y, 0) = "" & Mid(str, x, 64)
If Len(str) > 64 And Len(str) <= 128 And intPlaceholder = 6 Then
ActiveCell.Offset(1, -4).Resize(1, 4).Value = Chr(151) & Chr(151)
End If
If Len(str) > 128 And Len(str) < 192 And intPlaceholder = 6 Then
ActiveCell.Offset(1, -4).Resize(2, 4).Value = Chr(151) & Chr(151)
End If
If Len(str) >= 192 And intPlaceholder = 6 Then
ActiveCell.Offset(1, -4).Resize(3, 4).Value = Chr(151) & Chr(151)
End If
y = y + 1
Next
Else
Exit Sub
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal target As Range)
'Incident, Messages, Orders, Etc. Input
Dim rng As Range
Set rng = Intersect(target, Range("N12,N13,N14,N15,N16,N17,N18,N19,N20,N21,N22,N23,N24,N25,N26,N27,N28,N29,N30,N31,N32,N33,N34,N35,N36,N37,N38,N39,N40,N41,N42,N43,N44"))
If rng Is Nothing Then
Exit Sub
ElseIf target.Count > 14 Then
Exit Sub
Else
Dim cl As Range
For Each cl In rng
AutoCellAdvance
Next cl
End If
Selection.Font.Name = "arial"
Selection.Font.Size = 10
End Sub
Try this. The code below splits the input string, into an array of strings based on the delimiter " ". It then loops through the string array. Whenever it reaches a size of 64 it goes to the next line.
Sub AutoCellAdvance()
Dim strTemp As String
Dim arrStrings() As String
Dim i As Integer
Dim strNew As String
Range("A1").Activate
strTemp = InputBox("Enter Description of Activities (Max 192 characters)", "Incidents, Messages, Orders, Etc.")
'splits the string based on the delimeter space
arrStrings = Split(strTemp, " ")
strNew = ""
'loops through the strings
For i = LBound(arrStrings) To UBound(arrStrings)
If Len(strNew + arrStrings(i)) < 64 Then
'as long as its smaller than 64 its adds the string to the rest of the strings
strNew = strNew + arrStrings(i) + " "
Else
'if its larger than 64 then it prints the value in the active cell and goes down a row
ActiveCell = strNew
strNew = arrStrings(i)
Range(Cells(ActiveCell.Row + 1, ActiveCell.Column), Cells(ActiveCell.Row + 1, ActiveCell.Column)).Activate
End If
Next i
ActiveCell = strNew
End Sub
Also here's an article I've written about string processing on my blog. It also talks about splitting strings. String Processing
I'm not entirely sure how to word this but, I have an Excel macro that enables a search functionality within my workbook. My issue is that I need the search to understand 'é' as 'e'. So that if I search for 'Belem', my result would come back with 'Belém'. How would I go about this? Thanks for any time and consideration.
Sub city()
If ActiveSheet.Name <> "City" Then Exit Sub
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Sheets("Results").Range("3:10000").Delete
SearchTerm = Application.InputBox("What are you looking for?")
Application.ScreenUpdating = False
Range("W1") = SearchTerm
Range("W2:W" & LastRow).FormulaR1C1 = _
"=IF(ISERR(SEARCH(R1C23,RC[-22]&RC[-21]&RC[-20]&RC[-19]&RC[-18]&RC[-17]&RC[-16]&RC[-15]&RC[-15]&RC[-14]&RC[-13]&RC[-12]&RC[-11]&RC[-10]&RC[-9]&RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1])),0,1)"
If WorksheetFunction.CountIf(Columns(23), 1) = 0 Then
Columns(23).Delete
Application.ScreenUpdating = True
MsgBox "None found."
Else
For Each Cell In Range("A2:A" & LastRow)
If Cell.Offset(, 22) = 1 Then
Cell.Resize(, 51).Copy Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1)
x = x + 1
End If
Next Cell
Columns(22).Delete
Application.ScreenUpdating = True
If x = 1 Then
MsgBox "1 matching record was copied to Search Results tab."
Else
MsgBox x & " matching records were copied to Search Results tab."
End If
End If
End Sub
You can modify the search parameter and then use the like operator as follows:
Sub city()
Dim rngResult As Range
Dim searchTerm As String, counter As Integer
Dim values As Variant, value As Variant
If ActiveSheet.Name <> "City" Then Exit Sub
'First Cell with the results
Set rngResult = <First cell of the result Range>
'Uses a variant array to get all values from the range. This speeds up the routine
values = <Area of Search>.Value
'Converts to lowercase to do a case insensitive search (e.g. Belem = belem)
searchTerm = LCase(Application.InputBox("What are you looking for?"))
If searchTerm = "" Then Exit Sub
' "§" is just a placeholder
searchTerm = Replace(searchTerm, "e", "§")
searchTerm = Replace(searchTerm, "é", "§")
searchTerm = Replace(searchTerm, "§", "[eé]")
Application.ScreenUpdating = False
counter = 0
For Each value In values
If LCase(value) Like searchTerm Then
rngResult = value
Set rngResult = rngResult.Offset(1, 0) 'Moves to the next line
counter = counter + 1
End If
Next value
If counter = 0 Then
MsgBox "None found."
Else
MsgBox "Found " & counter & " results"
'Do what you need to do with the results
End If
Application.ScreenUpdating = True
End Sub
All the results will be at the column of rngResult.
The code works by replacing "e" and "é" by "§" and then replacing "§" by "[eé]", (e.g. "bélem" -> "bél§m" -> "b§l§m" -> "b[eé]l[eé]m").
The like will match either "e" or "é" on that position. You can learn more about it here or in the help files. Here is a Example:
bélem Like "b[eé]l[eé]m" ' true
belem like "b[eé]l[eé]m" ' true
recife like "b[eé]l[eé]m" ' false
You can search more graphs by adding other criteria like:
'Like will match "a","á", "à" and "ã"
searchTerm = Replace(searchTerm, "a", "§")
searchTerm = Replace(searchTerm, "á", "§")
searchTerm = Replace(searchTerm, "à", "§")
searchTerm = Replace(searchTerm, "ã", "§")
searchTerm = Replace(searchTerm, "§", "[aáàã]")
This method has the advantage that you only need one "translation" in order to do comparisons. This can improve the performance if you have a large dataset
You can keep an array of all the characters you want to replace and what you want to replace them with. It's easier if you "search" your data a little differently that using that formula. Here's how I would do it.
Sub FindCity()
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
'Put all the data into an array
vaData = ActiveSheet.UsedRange.Value
'Get the search therm
sSearchTerm = Application.InputBox("What are you looking for?")
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
For j = LBound(vaData, 2) To UBound(vaData, 2)
'Get rid of diacritial characters
sData = LCase(Anglicize(vaData(i, j)))
'Look for a match
If InStr(1, sData, LCase(Anglicize(sSearchTerm))) > 0 Then
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, UBound(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
Exit For
End If
Next j
Next i
End Sub
Public Function Anglicize(ByVal sInput As String) As String
Dim vaGood As Variant
Dim vaBad As Variant
Dim i As Long
Dim sReturn As String
'Replace any 'bad' characters with 'good' characters
vaGood = Split("S,Z,s,z,Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,D,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,d,n,o,o,o,o,o,u,u,u,u,y,y", ",")
vaBad = Split("Š,Ž,š,ž,Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ð,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ð,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ", ",")
sReturn = sInput
For i = LBound(vaBad) To UBound(vaBad)
sReturn = Replace$(sReturn, vaBad(i), vaGood(i))
Next i
Anglicize = sReturn
End Function
List of characters from Excel 2007 VBA Converting Accented Characters to Regular
I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v