Through much research I have figured out a code to truncate sentances stored in cells to 100 characters or less, and add the excess to a second string. I have been really struggling trying to turn this into a function.
I would like to have the function accept a range of (1 column by various rows) OR, if that isn't possible, an Array of the same range values. Also there should be a way to set the number of characters that each output string can hold, output as an array of strings.
i.e. wordWrap(Input 'range or array', maxLength as integer) output of wordWrap will be an array of the results
Here is my current code:
Sub wordWrap()
'This procedure is intended to check the character length of a string and truncate all the words over 100 characters
'To a second string. (basically a word wrap)
Dim sumCount As Integer, newCount As Integer, i As Integer
Dim newString As String, newString2 As String
Dim words As Variant
Dim lenwords(0 To 1000) As Variant
Dim myRange As Range
sumCount = 0
newCount = 0
newString = ""
newString2 = ""
With Range("Q:Q")
.NumberFormat = "#"
End With
Set myRange = Range("B3")
words = Split(myRange.Value, " ")
For i = 0 To UBound(words)
lenwords(i) = Len(words(i))
Range("Q3").Offset(i, 0) = CStr(words(i)) 'DEBUG
Range("R3").Offset(i, 0) = lenwords(i) 'DEBUG
If sumCount + (lenwords(i) + 1) < 100 Then
sumCount = sumCount + (lenwords(i) + 1)
newString = newString & " " & words(i)
Else
newCount = newCount + (lenwords(i) + 1)
newString2 = newString2 & " " & words(i)
End If
Next
'DEBUG
Range("S3") = CStr(newString)
Range("T3") = Trim(CStr(newString2))
Range("S4") = Len(newString)
Range("T4") = Len(newString2)
ActiveSheet.UsedRange.Columns.AutoFit
End Sub
So if a range of ("B2:B6")or equivalent array are entered at max 100 characters:
c = wordWrap(Range("B2:B6"),100)
Basically what this should do is count the length of each cell(or element) and truncate any extra words that make the string over 100 characters and concatenate them to the front of the next element in the output array to the next element of the output array. If that would put that element over 100 characters, then do the same process again until all of the elements contain sentence strings less then 100 characters long. It should add an extra element at the end to fit any leftover words.
I have been tearing out my hair trying to get this to work. I could use the advice of the experts.
Any help appreciated.
Example asked for:
http://s21.postimg.org/iywbgy307/trunc_ex.jpg
The ouput should be into an array, though, and not directly back to the worksheet.
The function:
Function WordWrap(ByVal Rng As Range, Optional ByVal MaxLength As Long = 100) As String()
Dim rCell As Range
Dim arrOutput() As String
Dim sTemp As String
Dim OutputIndex As Long
Dim i As Long
ReDim arrOutput(1 To Evaluate("CEILING(SUM(LEN(" & Rng.Address(External:=True) & "))," & MaxLength & ")/" & MaxLength) * 2)
For Each rCell In Rng.Cells
If Len(Trim(sTemp & " " & rCell.Text)) > MaxLength Then
OutputIndex = OutputIndex + 1
arrOutput(OutputIndex) = Trim(Left(sTemp & " " & rCell.Text, InStrRev(Left(sTemp & " " & rCell.Text, MaxLength), " ")))
sTemp = Trim(Mid(sTemp & " " & rCell.Text, Len(arrOutput(OutputIndex)) + 2))
For i = 1 To Len(sTemp) Step MaxLength
If Len(sTemp) < MaxLength Then Exit For
OutputIndex = OutputIndex + 1
arrOutput(OutputIndex) = Trim(Left(sTemp, InStrRev(Left(sTemp, MaxLength), " ")))
sTemp = Trim(Mid(sTemp, Len(arrOutput(OutputIndex)) + 2))
Next i
Else
OutputIndex = OutputIndex + 1
arrOutput(OutputIndex) = Trim(sTemp & " " & rCell.Text)
sTemp = ""
End If
Next rCell
OutputIndex = OutputIndex + 1
arrOutput(OutputIndex) = sTemp
ReDim Preserve arrOutput(1 To OutputIndex)
WordWrap = arrOutput
Erase arrOutput
End Function
The call:
Sub tgr()
Dim arrWrapped() As String
arrWrapped = WordWrap(Range("B2:B6"), 100)
MsgBox Join(arrWrapped, Chr(10) & Chr(10))
End Sub
Instead of a msgbox, you could output it to a sheet, or do whatever else you wanted.
going to say you get passed a string, and want to return an array
performance might be slow with this approach
dim words(1) as variant
dim lastSpace as Integer
dim i as Integer
words(1) = Cells(1, 1)
while(Len(words(UBound(words) - 1)) > 100) 'check if the newest array is > 100 characters
Redim words(UBound(words) + 1)
'find the last space
for i = 0 to 100
if(words(i) = " ") Then
lastSpace = i
EndIF
Next
words(UBound(words) - 1) = Mid(words(UBound(words) - 2), lastSpace) 'copy words after the last space before the 100th character
words(UBound(words) - 2) = Left(words(UBound(words) - 2), 100 - lastSpace) 'copy the words from the beginning to the last space
Wend
Not sure if this will compile/run but it should give you the general idea
Related
How to find smallest element of array V(12,9) and its number?
Private Sub Command2_Click()
Dim V(1 To 12, 1 To 9) As Integer
Randomize
For i = 1 To 12
For j = 1 To 9
V(i, j) = Rnd * 50
Next j
Next i
Identify the Minimum Value in a 2D Array
See the information and results in the Immediate window (Ctrl+G). It's nicer and more educational than the presentation in the message box.
With such small numbers you could replace all the Longs with Integers if that is a requirement. Here is a link describing why we mostly don't use Integer anymore.
Private Sub Command2_Click()
Const Max As Long = 50
' Populate the array.
Dim V(1 To 12, 1 To 9) As Long
Dim i As Long
Dim j As Long
Randomize
For i = 1 To 12
For j = 1 To 9
V(i, j) = Rnd * Max
Next j
Next i
Debug.Print GetDataString(V, , , "Random numbers from 0 to " & Max)
Debug.Print "How Min Was Changed in the Loop (It Started at " & Max & ")"
Debug.Print "The array was looped by rows."
Debug.Print "Visually find the following values to understand what happened."
Debug.Print "i", "j", "Min"
' Calculate the minimum.
Dim Min As Long: Min = Max
For i = 1 To 12
For j = 1 To 9
If V(i, j) < Min Then
Min = V(i, j)
Debug.Print i, j, Min
End If
Next j
Next i
Debug.Print "The minimum is " & Min & "."
MsgBox GetDataString(V, , , "Random numbers from 0 to " & Max) & vbLf _
& "The minimum is " & Min & ".", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a 2D array in a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetDataString( _
ByVal Data As Variant, _
Optional ByVal RowDelimiter As String = vbLf, _
Optional ByVal ColumnDelimiter As String = " ", _
Optional ByVal Title As String = "PrintData Result") _
As String
' Store the limits in variables
Dim rLo As Long: rLo = LBound(Data, 1)
Dim rHi As Long: rHi = UBound(Data, 1)
Dim cLo As Long: cLo = LBound(Data, 2)
Dim cHi As Long: cHi = UBound(Data, 2)
' Define the arrays.
Dim cLens() As Long: ReDim cLens(rLo To rHi)
Dim strData() As String: ReDim strData(rLo To rHi, cLo To cHi)
' For each column ('c'), store strings of the same length ('cLen')
' in the string array ('strData').
Dim r As Long, c As Long
Dim cLen As Long
For c = cLo To cHi
' Calculate the current column's maximum length ('cLen').
cLen = 0
For r = rLo To rHi
strData(r, c) = CStr(Data(r, c))
cLens(r) = Len(strData(r, c))
If cLens(r) > cLen Then cLen = cLens(r)
Next r
' Store strings of the same length in the current column
' of the string array.
If c = cHi Then ' last row (no column delimiter ('ColumnDelimiter'))
For r = rLo To rHi
strData(r, c) = Space(cLen - cLens(r)) & strData(r, c)
Next r
Else ' all but the last row
For r = rLo To rHi
strData(r, c) = Space(cLen - cLens(r)) & strData(r, c) _
& ColumnDelimiter
Next r
End If
Next c
' Write the title to the print string ('PrintString').
Dim PrintString As String: PrintString = Title
' Append the data from the string array to the print string.
For r = rLo To rHi
PrintString = PrintString & RowDelimiter
For c = cLo To cHi
PrintString = PrintString & strData(r, c)
Next c
Next r
' Assign print string as the result.
GetDataString = PrintString
End Function
First you need to declare the data type of variables i and j
Dim i as Long
Dim j as Long
second, your array name V not A so correct this line
V(i, j) = Rnd * 50
finally, if your array contains numbers you can use this line
Debug.Print WorksheetFunction.Min(V)
I have this script in VBA and I need to apply it to different paths that I need to split. Each path is different in length and has several slash delimiters (/) separating it.
If I exceed the number of elements in the array in the LBound function, an error is returned to me.
Question
How do I dynamically combine this pattern based on length.
Example with 3 elements
That is, if I have an initial array of this type
"category / subcategory / product"
I have to get
"category; category> subcategory; category> subcategory> product"
I have many paths of this type, but sometimes they are composed of 3 parts, other times 4, 5 or even more. This is my starting VBA.
Public Sub TestMe()
Dim strFolderString As String
Dim arrFolderString As Variant
Dim result As String
Dim lenght As Integer
strFolderString = "category\subcategory\product\CustomerName\ProductName\2017\"
arrFolderString = Split(strFolderString, "\")
lenght = UBound(arrFolderString)
result = _
arrFolderString(LBound(arrFolderString) + 1) & ";" & _
arrFolderString(LBound(arrFolderString) + 1) & " > " & _
arrFolderString(LBound(arrFolderString) + 2) & ";" & _
arrFolderString(LBound(arrFolderString) + 1) & " > " & _
arrFolderString(LBound(arrFolderString) + 2) & " > " & _
arrFolderString(LBound(arrFolderString) + 3)
Debug.Print result
End Sub
You may try the following approach to get the dynamic path infos by a tricky loop restricting the inner loop to the current outer value:
Sub PathInfo()
'1) define path input
Dim strFolderString As String
strFolderString = _
"category\subcategory\product\CustomerName\ProductName\2017\"
'remove end slash
strFolderString = Replace(strFolderString & "\", "\\", "")
'2) split parts into array
Dim arrFolderString As Variant
arrFolderString = Split(strFolderString, "\")
'3) Provide for sufficient elements in results array
Dim lastIndex As Long: lastIndex = UBound(arrFolderString)
Dim results(): ReDim results(0 To lastIndex)
'4) Join Path infos
Dim i As Long, j As Long
For i = 0 To lastIndex
Dim delim As String: delim = ""
For j = 0 To i ' << restrict inner loop to i :-)
Dim tmp As String
results(i) = tmp & delim & arrFolderString(j)
delim = ">"
Next j
tmp = results(i)
Next
'5) Show Result
Debug.Print Join(results, ";" & vbNewLine)
End Sub
Results in VB Editors immediate window
category;
category>subcategory;
category>subcategory>product;
category>subcategory>product>CustomerName;
category>subcategory>product>CustomerName>ProductName;
category>subcategory>product>CustomerName>ProductName>2017
i foung similiar topic, but i can t apply completily that solution to my needs... I want to upgrade excel workbook at my job by making it more auto-entry capable.
Mostly i use excel functions, but sometimes i need some VBA coding, which im not very familiar with. So my problem is, that i need something like this mentioned on this thread. How to get the first and last numbers in a sequence
I have box numbers in different sequince in ascening order starting from "A4" to X on
Sheet1. Example Box numbers: M004935149,M004935150,M004935151,M004935202,M004935203,M004935204,M004935205, is it possible when i copy&paste(values) to sheet2 from "A4" to X (depenting on number of boxes copied) to make a string, sentence or whatever is called in specific form in some other cells. M004935149-151 // M004935202-205. I used code from topic in link above, it can make half job done but i can t figure it out how to make entry from desired cell range and display them on worksheet, and to display values in desired format. Link of screen shoots from my example is following:
I hope that someone can help. Thanks in advance.
Check this
Option Explicit
Sub test2()
Dim ws As Worksheet
Dim arr() As String, result As String, letter As String, cellValue As String, tempLastElement As String
Dim lastColumn As Long, counter As Long
Dim firstColumn As Integer, targetRow As Integer, i As Integer
Set ws = Worksheets("Sheet1")
firstColumn = 1 'number of first column with target data
targetRow = 1 'number of row with target data
lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
ReDim arr(1 To lastColumn - firstColumn + 1)
letter = Left(ws.Cells(targetRow, firstColumn).Value, 1) 'if count of character in start of string will be more 1, replace 1 on to count of characters
For i = 1 To UBound(arr)
cellValue = ws.Cells(targetRow, i).Value
arr(i) = Right(cellValue, Len(cellValue) - 1) 'if count of character in start of string will be more 1, replace 1 on to count of characters
Next i
ReDim sequenceArr(1 To UBound(arr))
sequenceArr(1) = arr(1)
counter = 2
For i = 1 To UBound(arr) - 1
If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then
tempLastElement = arr(i + 1)
sequenceArr(counter) = tempLastElement
Else
counter = counter + 1
sequenceArr(counter) = arr(i + 1)
counter = counter + 1
End If
Next
ReDim Preserve sequenceArr(1 To counter)
result = ""
counter = 1
For i = 1 To UBound(sequenceArr) - 1
If counter > UBound(sequenceArr) Then Exit For
If result = "" Then
result = letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
Else
result = result & "//" & letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
End If
Next
ws.Range("D4").Value = result
End Sub
Result on
I'm trying to compare two arrays of data in MS Access - one is generated from an API GET, and the other is generated from two columns of a table. I'm using a double loop to do the comparison, I suspect this isn't the best way but I'm still learning my way around loops and arrays. The code I'm using is as follows:
Sub ParseList(ResCount As Long)
Dim db As DAO.Database
Dim rstConts As DAO.Recordset
Dim midstr As String, emailstr As String, Fname As String, Lname As String, SubStatus As String, echeck As String, Mecheck As String, ArrEcheck As String, ArrMecheck As String, MSub As String
Dim ArrResp() As String
Dim ArrConts() As Variant
Dim SubStart As Long, SubCount As Long, Fstart As Long, Fcount As Long, Lstart As Long, LCount As Long, Diffcount As Long, c As Long, i As Long, t As Long, y As Long, u As Long, v As Long
Dim IsSub As Boolean
Set db = CurrentDb
Udate = SQLDate(Now)
ReDim ArrResp(1 To ResCount, 1 To 4) As String
'This section parses a JSON response into an array
For i = 1 To ResCount
midstr = ""
emailstr = ""
x = InStr(t + 2, GetListStr, "}}") + 21
y = InStr(x + 1, GetListStr, "}}")
If y = 0 Then
Exit Sub
End If
midstr = Mid(GetListStr, x, y - x)
emailstr = Left(midstr, InStr(midstr, ",") - 2)
SubStart = InStr(midstr, "Status") + 9
SubCount = InStr(InStr(midstr, "Status") + 8, midstr, ",") - SubStart - 1
SubStatus = Replace(Mid(midstr, SubStart, SubCount), "'", "''")
Fstart = InStr(midstr, ":{") + 11
Fcount = InStr(InStr(midstr, ":{") + 11, midstr, ",") - (Fstart + 1)
Fname = Replace(Mid(midstr, Fstart, Fcount), "'", "''")
Lstart = InStr(midstr, "LNAME") + 8
LCount = InStr(InStr(midstr, "LNAME") + 8, midstr, ",") - (Lstart + 1)
Lname = Replace(Mid(midstr, Lstart, LCount), "'", "''")
If SubStatus = "subscribed" Then
MSub = "True"
Else
MSub = "False"
End If
ArrResp(i, 1) = emailstr
ArrResp(i, 2) = MSub
ArrResp(i, 3) = Fname
ArrResp(i, 4) = Lname
t = y
Next i
'This section grabs two columns from a database table and adds them to a second array
Set rstConts = CurrentDb.OpenRecordset("SELECT Primary_Email, EMailings FROM TBLContacts")
rstConts.MoveLast
rstConts.MoveFirst
c = rstConts.RecordCount
ReDim ArrConts(1 To c) As Variant
ArrConts = rstConts.GetRows(c)
'This loops through the JSON response array, and when it finds a matching value in the Table array it checks if a second value in the table array matches or not
For u = 1 To ResCount
Debug.Print u
echeck = ArrResp(u, 1)
Mecheck = ArrResp(u, 2)
For v = 0 To c
If ArrConts(0, v) = "" Then
Else
ArrEcheck = ArrConts(0, v)
ArrMecheck = ArrConts(1, v)
If ArrEcheck = echeck Then
If ArrMecheck = Mecheck Then
Debug.Print echeck & "Match"
Else
Debug.Print echeck & "No Match"
End If
End If
End If
Next v
Next u
MsgBox "Done"
End Sub
The code above simply doesn't complete and the msgbox is never shown. The debug.print line near the end only goes to 1, and I can't figure out why. If I remove the conditions from the second loop section:
If ArrConts(0, v) = "" Then
Else
ArrEcheck = ArrConts(0, v)
ArrMecheck = ArrConts(1, v)
If ArrEcheck = echeck Then
If ArrMecheck = Mecheck Then
Debug.Print echeck & "Match"
Else
Debug.Print echeck & "No Match"
End If
End If
End If
Then I can successfully complete the Main loop, and receive the 'Done' message. But I've been unable to narrow down why the second loop isn't completing properly, and I'm stuck.
Because arrays are zero-indexed, you need to subtract 1 from the upper limit of nested For loop which should have thrown an error on the subsequent If line when loop exceeded the record limit.
For u = 1 To ResCount
Debug.Print u
echeck = ArrResp(u, 1)
Mecheck = ArrResp(u, 2)
For v = 0 To c - 1 ' REDUCE UPPER LIMIT BY 1
If ArrConts(0, v) = "" Then ' LINE NO LONGER SHOULD ERR OUT
...
Next v
Next u
With that said, consider parsing JSON to an MS Access table using the VBA-JSON library. Then use SQL to check values with JOIN and WHERE in set-based processing between table to table. This is much more efficient that looping between arrays.
I am using the following code to chop up a column of comma-separated lists and to return each entry in a new row:
Sub SliceNDice()
'
' Splits the locations cells according to commas and pushes to new rows
' Code courtesy of brettdj (http://stackoverflow.com/questions/8560718/split-comma-separated-entries-to-new-rows)
'
Dim objRegex As Object
Dim x
Dim Y
Dim lngRow As Long
Dim lngCnt As Long
Dim tempArr() As String
Dim strArr
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "^\s+(.+?)$"
'Define the range to be analysed
x = Range([a1], Cells(Rows.Count, "c").End(xlUp)).Value2
ReDim Y(1 To 3, 1 To 1000)
For lngRow = 1 To UBound(x, 1)
'Split each string by ","
tempArr = Split(x(lngRow, 3), ",")
For Each strArr In tempArr
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
Y(1, lngCnt) = x(lngRow, 1)
Y(2, lngCnt) = x(lngRow, 2)
Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
Next
Next lngRow
'Dump the re-ordered range to columns E:G
[e1].Resize(lngCnt, 3).Value2 = Application.Transpose(Y)
End Sub
While this code works perfectly, it has a fatal flaw in that any double-commas in the cells of column C will result in blank cells pushed to the new rows in column G.
Does anyone know how to edit the code so that it does not create new rows with empty cells in column G, but skips them and enters the next rows in their places as if the superfluous commas were never included in column C at all?
Just test for the string length of strArr as the first operation inside the For Each strArr In tempArr loop.
For Each strArr In tempArr
If CBool(Len(strArr)) Then
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
Y(1, lngCnt) = x(lngRow, 1)
Y(2, lngCnt) = x(lngRow, 2)
Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
End If
Next strArr
You could loop on the occurence of double comma to clean up the input as opposed to fixing the output, here is a working example:
Text in A1: Hello,,World,This,,Is,,,,,,,A,,Test
Sub TestString()
Dim MyString As String
MyString = Range("A1").Text
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
MyString = Replace(MyString, ",,", ",")
Loop
MsgBox MyString
End Sub
You would do this just before splitting
If you want it as a function (would be better in your case) do this:
Function FixDoubleComma(MyString As String)
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
MyString = Replace(MyString, ",,", ",")
Loop
FixDoubleComma = MyString
End Function
Then replace this in your code:
tempArr = Split(x(lngRow, 3), ",")
With this:
tempArr = Split(FixDoubleComma(x(lngRow, 3)), ",")
I have a little sample that solves blanks everywhere
Sub RemoveBlanks()
Dim mystr As String
Dim arrWithBlanks() As String
Dim arrNoBlanks() As String
Dim i As Integer
mystr = ",tom,jerry, ,,spike,," 'Blanks everywhere (beginning, middle and end)
arrWithBlanks = Split(mystr, ",")
ReDim arrNoBlanks(0 To 0)
Debug.Print "Array with blanks:"
'Loop through the array with blanks
For i = LBound(arrWithBlanks) To UBound(arrWithBlanks)
'Check if there is a blank (or element with spaces only)
If Trim(arrWithBlanks(i)) = "" Then
Debug.Print i & " (blank)"
Else
Debug.Print i & " " & arrWithBlanks(i)
If arrNoBlanks(UBound(arrNoBlanks)) <> "" Then ReDim Preserve arrNoBlanks(0 To UBound(arrNoBlanks) + 1)
arrNoBlanks(UBound(arrNoBlanks)) = arrWithBlanks(i)
End If
Next i
Debug.Print "Array with NO blanks:"
For i = LBound(arrNoBlanks) To UBound(arrNoBlanks)
Debug.Print i & " " & arrNoBlanks(i)
Next i
End Sub
Everything will be displayed in the immediate window (Press Ctrl + G to show it)
The result will look like this:
Array with blanks:
0 (blank)
1 tom
2 jerry
3 (blank)
4 (blank)
5 spike
6 (blank)
7 (blank)
Array with NO blanks:
0 tom
1 jerry
2 spike