Difficulty in finding end of row in VB Excel - excel

I am reading in information from a .txt file, This text file has 2 row and 6 column; each element is separated by space or tab. I have the data to read all the strings but I find difficult in putting the data to the cells. How can I find end of first Row.
Text File:
$SUBCASE 1 1
$DISP 0 509 5 1 2
Below is the complete code, I'm getting only the first character string and rest not...
Private Sub PCH_Click()
Dim arTemp() As Variant
Dim lRet As String
Dim sVal As String
Dim Row As Long
Dim Col As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'Default method Uses Open Dialog To Show the Files
lRet = Application.GetOpenFilename("PCH files (*.pch), *.*")
'Reads the file into characters
sVal = OpenTextFileToString2(lRet)
Dim tmp As Variant
tmp = SplitMultiDelims(sVal, ",;$ ", True) ' Place the 2nd argument with the list of delimiter you need to use
Row = 0
For i = LBound(tmp, 1) To UBound(tmp, 1)
Row = Row + 1
Col = 1
While Not vbNewLine = ""
ws.Cells(Row, Col) = tmp(i) 'output on the first column
MsgBox (tmp(i))
Col = Col + 1
Wend
Next i
End Sub
Function OpenTextFileToString2(ByVal strFile As String) As String
' RB Smissaert - Author
Dim hFile As Long
hFile = FreeFile
Open strFile For Input As #hFile
OpenTextFileToString2 = Input$(LOF(hFile), hFile)
Close #hFile
End Function
Function SplitMultiDelims(ByRef Text As String, ByRef DelimChars As String, _
Optional ByVal IgnoreConsecutiveDelimiters As Boolean = False, _
Optional ByVal Limit As Long = -1) As String()
Dim ElemStart As Long, N As Long, M As Long, Elements As Long
Dim lDelims As Long, lText As Long
Dim Arr() As String
lText = Len(Text)
lDelims = Len(DelimChars)
If lDelims = 0 Or lText = 0 Or Limit = 1 Then
ReDim Arr(0 To 0)
Arr(0) = Text
SplitMultiDelims = Arr
Exit Function
End If
ReDim Arr(0 To IIf(Limit = -1, lText - 1, Limit))
Elements = 0: ElemStart = 1
For N = 1 To lText
If InStr(DelimChars, Mid(Text, N, 1)) Then
Arr(Elements) = Mid(Text, ElemStart, N - ElemStart)
If IgnoreConsecutiveDelimiters Then
If Len(Arr(Elements)) > 0 Then Elements = Elements + 1
Else
Elements = Elements + 1
End If
ElemStart = N + 1
If Elements + 1 = Limit Then Exit For
End If
Next N
'Get the last token terminated by the end of the string into the array
If ElemStart <= lText Then Arr(Elements) = Mid(Text, ElemStart)
'Since the end of string counts as the terminating delimiter, if the last character
'was also a delimiter, we treat the two as consecutive, and so ignore the last elemnent
If IgnoreConsecutiveDelimiters Then If Len(Arr(Elements)) = 0 Then Elements = Elements - 1
ReDim Preserve Arr(0 To Elements) 'Chop off unused array elements
SplitMultiDelims = Arr
End Function

You can read a file row by row with following code
Sub IOTest()
Dim fnum, i As Integer, j As Integer
Dim line As String
Dim lines As Variant
Dim regEx As Object
Set regEx = CreateObject("vbscript.regexp")
With regEx
.Pattern = "\s{1}" 'only one whitespace
.Global = True 'find all occurrences
End With
fnum = FreeFile()
Open ThisWorkbook.Path & "\IO_Test.txt" For Input As #fnum
Do Until EOF(fnum) 'until End of file
i = i + 1
Input #fnum, line 'load row into line
'First replace found sole whitespaces with ","
'Then split on the ","s
lines = Split(regEx.Replace(line, ","), ",")
For j = LBound(lines) To UBound(lines)
Cells(i, j + 1) = lines(j)
Next j
Loop
Close #fnum
End Sub
I tested this with the strings
"$SUBCASE" & vbTab & "1" & vbTab & vbTab & vbTab & vbTab & "1"
"$DISP" & vbTab & "0" & vbTab & "509" & vbTab & "5" & vbTab & "1" & vbTab & "2"
And it only works if you have one whitespace(eg. space, tab,...) separating the data. If you have more than one whitespace between the data it gets trickier. But if you can provide an example on how the data is separated I can take a look at it.
I hope it helps, let me know either way ;)

Related

Read Text file to worksheet

I have a Text file which looks like this
'52132205501000655
JAMES BOND
CC34TYU ,'006039869 , 350000, -358300.51, 0,19-04-2022, 8300.51, 0,001A
1 DAY < ACCOUNT OVERDRAWN <= 90 DAYS
'0362205501000655
WILSON JOE
CC34ZYU ,'006039869 , 550000, -358300.51, 0,19-04-2022, 8300.51, 0,001A
1 DAY < ACCOUNT OVERDRAWN <= 60DAYS
'0552205501000955
QUEEN VELVET
CDDFTYU ,'006039869 , 350000, -358300.51, 0,19-04-2022, 8300.51, 0,001A
1 DAY < ACCOUNT OVERDRAWN <= 50DAYS
I want output in a spreadsheet like MS Excel like this
'52132205501000655 JAMES BOND CC34TYU '006039869 350000 -358300.51 0 19-04-2022 8300.51 1 DAY < ACCOUNT OVERDRAWN <= 90 DAYS
which is to say that until my program encounters a blank line it should read all the values and if it contains a delimiter(, in my case) split them and put them in consecutive rows. My code reads as
Sub ReadTextFileWithSeparators()
Dim StrLine As String
Dim FSO As New FileSystemObject
Dim TSO As Object
Dim StrLineElements As Variant
Dim RowIndex As Long
Dim ColIndex As Long
Dim Delimiter As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile("C:\temp\sample.txt")
Delimiter = ","
RowIndex = 1
Do While TSO.AtEndOfStream = False
StrLine = TSO.ReadLine
Do While StrLine <> vbNullString
StrLine = TSO.ReadLine
StrLineElements = Split(StrLine, Delimiter)
For ColIndex = LBound(StrLineElements) To UBound(StrLineElements)
Cells(RowIndex, ColIndex + 1).Value = StrLineElements(ColIndex)
Next ColIndex
Loop
RowIndex = RowIndex + 1
Loop
TSO.Close
Set TSO = Nothing
Set FSO = Nothing
End Sub
However i dont seem to get the desired output. Where i am doing wrong
Please, test the next code. It uses arrays and should be very fast, processing only in memory. It assumes that all text file contains groups of four lines, separate by an empty line. It will return in separate cells for each file line. The processing result will be dropped in the active sheet, starting from "A1" (header included):
Sub ReadTextFile()
Dim textFileName As String, arrTxt, arrRet, arr4Lines, arrL, arrFin, colNo As Long
Dim i As Long, j As Long, L As Long, k As Long, kk As Long, n As Long, sep As String
textFileName = "C:\temp\sample.txt"
sep = vbCrLf 'ito be changed with vbCr or vbLf if the text file will not be split on the chosen line separator
arrTxt = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(textFileName, 1).ReadAll, sep)
If UBound(arrTxt) = 0 Then MsgBox "Strange line separator..." & vbCrLf & _
"Try replacing it with 'vbCr' or 'vbLf 'and run the code again.", vbInformation, _
"Separator change needed": Exit Sub
colNo = UBound(Split(arrTxt(2), ",")) + 4 'the number of necessary columns in the final array (in a consistent txt file)
ReDim arrFin(1 To UBound(arrTxt) + 5, 1 To colNo): kk = 1 'the final array to drop its content in the sheet
For i = 0 To UBound(arrTxt) Step 5
ReDim arr4Lines(UBound(Split(arrTxt(2), ",")) * 4) 'to be sure that it is enough space to place all split elements...
For j = 0 To 3
If left(arrTxt(i + j), 1) = "=" Or arrTxt(i + j) = "" Then Exit For 'for the ending file part
arrL = Split(arrTxt(i + j), ",")
For L = 0 To UBound(arrL)
arr4Lines(k) = WorksheetFunction.Trim(arrL(L)): k = k + 1 'place in the array all the line elements (separated by comma)
Next L
Next j
If k > 0 Then
ReDim Preserve arr4Lines(k - 1) 'keep only the loaded array elements
For n = 0 To k - 1
arrFin(kk, n + 1) = arr4Lines(n) 'place the elements in the final array
Next n
kk = kk + 1 'increment the final array row
End If
Erase arr4Lines: k = 0
Next i
'drop the processed array content at once and format a little the respective range:
With ActiveSheet.Range("A2").Resize(kk - 1, colNo)
.value = arrFin
.rows(1).Offset(-1) = Array("Column1", "Column2", "Column3", "Column4", "Column5", "Column6", _
"Column7", "Column8", "Column9", "Column10", "Column11", "Column12") 'place here the necessary headers
.EntireColumn.AutoFit
End With
End Sub

I need an algorithm that count the number of words in column M that start with letters "a" and "A" in excel VBA

Here I have code that only counts the number of words and I dont know what to do to make it count the words that start with letter "A" and "a" in column M
Sub CountWords()
Dim xRg As Range
Dim xRgEach As Range
Dim xAddress As String
Dim xRgVal As String
Dim xRgNum As Long
Dim xNum As Long
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Introduceti diapazonul:", "Selectare", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(xRg) = xRg.Count Then
MsgBox "Numarul de cuvinte este: 0", vbInformation, ""
Exit Sub
End If
For Each xRgEach In xRg
xRgVal = xRgEach.Value
xRgVal = Application.WorksheetFunction.Trim(xRgVal)
If xRgEach.Value <> "" Then
xNum = Len(xRgVal) - Len(Replace(xRgVal, " ", "")) + 1
xRgNum = xRgNum + xNum
End If
Next xRgEach
MsgBox "Numarul de cuvinte: " & Format(xRgNum, "#,##0"), vbOKOnly, "Raspuns"
Application.ScreenUpdating = True
End Sub
Assuming that each cell contains a single word, use:
Sub ACount()
Dim i As Long, N As Long, Kount As Long
Dim ch As String
Kount = 0
N = Cells(Rows.Count, "M").End(xlUp).Row
For i = 1 To N
ch = Left(Cells(i, "M").Value, 1)
If ch = "a" Or ch = "A" Then Kount = Kount + 1
Next i
MsgBox Kount
End Sub
EDIT#1:
If the cells can contain more than one word (separated by spaces), the use:
Sub ACount()
Dim i As Long, N As Long, Kount As Long
Dim ch As String
Kount = 0
N = Cells(Rows.Count, "M").End(xlUp).Row
For i = 1 To N
arr = Split(Cells(i, "M").Value, " ")
For Each A In arr
ch = Left(A, 1)
If ch = "a" Or ch = "A" Then Kount = Kount + 1
Next A
Next i
MsgBox Kount
End Sub
Alternative via arrays including found word list display
It might be helpful to include a list of all valid words to the demanded count result.
Just to demonstrate a similar approach as Gary, but using arrays instead of a range loop,
I condensed the main procedure to three steps using a help function for step [1]:
[1] get data and provide for a sufficient wrds array by calling a help function getData()
[2] count & collect valid words in a loop through all words,
[3] display count cnt (or: UBound(wrds) plus list of valid words (►1-based 1-dim arraywrds)
Furthermore it's possible to analyze single words as well as word groups separated by spaces.
Sub ACount2()
Const SEARCHLETTER As String = "a" ' << change to any wanted search letter
'[1] get data and provide for sufficient wrds array
Dim allWrds, wrds: allWrds = getData(Sheet1, wrds) ' << change Sheet1 to your sheet's Code(Name)
'[2] count & collect valid words
Dim i As Long, letter As String, cnt As Long
For i = LBound(allWrds) To UBound(allWrds) ' loop through original words
letter = LCase(Left(allWrds(i), 1)) ' compare with search letter (lower case)
If letter = SEARCHLETTER Then cnt = cnt + 1: wrds(cnt) = allWrds(i)
Next i
ReDim Preserve wrds(1 To cnt)
'[3] display count plus list of valid words
MsgBox cnt & " words starting with {A|a}:" & _
vbNewLine & vbNewLine & _
Join(wrds, ", "), vbInformation
End Sub
Help function getData() called by above procedure
Function getData(sht As Worksheet, wrds, Optional ByVal col = "M", Optional ByVal StartRow As Long = 2)
'Purpose: get column data of a given worksheet and return to a "flat" array; provide for a sufficient wrds array
'a) get 2-dim data (starting in cell M2 by default) and transpose to 1-dim "flat" array
Dim lastRow As Long: lastRow = sht.Cells(sht.Rows.Count, col).End(xlUp).Row
Dim data: data = Split(Join(Application.Transpose(sht.Range(col & StartRow & ":" & col & lastRow)), " "), " ")
'b) provide for maximum elements in found words in calling procedure (implicit ByRef!)
ReDim wrds(1 To UBound(data))
'c) return 1-based "flat" 1-dim data array
getData = data
End Function

Counting file from a date range depending on date modified

I have a file path in Column A and want to display the count of how many files are between a date range, and if there are any files I want to be able to have a comment on the cell showing the file names and dates.
I have a code that I've gotten help on, but when the code runs it counts all the files in the folder and the comment only appears on the last number in the column.
Sub CreateMouseoverList(Optional FileFilter As String, Optional LowDate As Date, Optional HighDate As Date)
Dim Cell As Range
Dim Ext As Variant
Dim File As Object
Dim FileCnt As Long
Dim Files As Object
Dim Folder As Variant
Dim Item As Variant
Dim List() As Variant
Dim MaxLen As Long
Dim ModDate As Date
Dim m As Long
Dim n As Long
Dim Note As Comment
Dim Text As String
If IsMissing(FileFilter) Then FileFilter = "*.*"
' // Is there is no LowDate then use 1.
If LowDate = 0 Then LowDate = 2
' // If there is no HighDate then use today's date.
If HighDate = 0 Then HighDate = Now()
With CreateObject("Shell.Application")
For Each Cell In Range("A1", Cells(Rows.count, "A").End(xlUp))
FileCnt = 0
ReDim List(1 To 1)
Set Note = Cell.Offset(0, 1).Comment
If Note Is Nothing Then Set Note = Cell.Offset(0, 1).AddComment
Note.Shape.TextFrame.Characters(1, Len(Note.Text)).Delete
Note.Shape.TextFrame.Characters.Font.FontStyle = "regular"
Set Folder = .Namespace(Cell.Value)
If Not Folder Is Nothing Then
Set Files = Folder.Items
For Each Ext In Split(FileFilter, ";")
Files.Filter 64, Ext
Text = vbLf & " " & Ext & " Files | " & vbLf
List(UBound(List)) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
Text = String(Len(Text), "-") & " | " & vbLf
List(UBound(List)) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
Note.Shape.TextFrame.Characters.Font.Name = "Courier New"
Note.Shape.TextFrame.AutoSize = True
For Each File In Files
ModDate = File.ModifyDate
If ModDate >= LowDate And HighDate <= HighDate Then
FileCnt = FileCnt + 1
Text = File.Name & " | " & ModDate & vbLf
List(n) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
If Len(Text) > MaxLen Then MaxLen = Len(Text)
End If
Next File
Next Ext
Cell.Offset(0, 1).Value = FileCnt
Else
Cell.Offset(0, 1).Value = "Folder not found."
End If
Next Cell
End With
For Each Item In List
m = Len(Item)
n = Note.Shape.TextFrame.Characters.count + 1
Item = Split(Item, "|")
If UBound(Item) > -1 Then
Text = Item(0) & String(MaxLen - m, 32) & Item(1)
Note.Shape.TextFrame.Characters(n, Len(Text)).Insert Text
End If
Next Item
End Sub
Sub TestIt()
Call CreateMouseoverList("*.txt;*.xls", "4/1/2019","6/10/2019")
End Sub
I would like to be able to count all the files that are between a date range and display what the files are as well as the count.

Macro to insert a formula and drag it down

I am trying to split the contents of a column into various columns. The column has content that looks like this:
3-BW16569*AW34586*AW34587
3- LVA18140 & LVA19222
3-LVA22841
3- JDSC RELOAD
3 - LV1 TO JDSC 6/21
3- LVU21690
3-LVA19520*LVU21739
3- R241974/R241974
The column is not in a particular format but always has different symbols between the elements to separate them. Can a macro code help with this or a excel function. Thank you!
All thanks to alainbryden for the function SplitMultiDelims() . . don't change it, foo() may help you through in how to use it in your problem...
Sub foo()
Dim ws As Worksheet
Dim sizeArr, index As Integer
Dim Arr() As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim str As String
Dim dilimiters As String
Dim str1 As String
dilimiters = " -*" ' provide all of them
str = "3-BW16569*AW34586*AW34587" ' read the string
'str = ws.Cells(1, 1).Value
Debug.Print str
Arr = SplitMultiDelims(str, dilimiters) ' delimit
sizeArr = UBound(Arr) ' get no of different strings you have
For index = 0 To sizeArr Step 1
str1 = Arr(index) ' get the string
Debug.Print str1
' now paste where evere you want
Next
End Sub
Function SplitMultiDelims(ByRef Text As String, ByRef DelimChars As String, _
Optional ByVal IgnoreConsecutiveDelimiters As Boolean = False, _
Optional ByVal Limit As Long = -1) As String()
Dim ElemStart As Long, N As Long, M As Long, Elements As Long
Dim lDelims As Long, lText As Long
Dim Arr() As String
lText = Len(Text)
lDelims = Len(DelimChars)
If lDelims = 0 Or lText = 0 Or Limit = 1 Then
ReDim Arr(0 To 0)
Arr(0) = Text
SplitMultiDelims = Arr
Exit Function
End If
ReDim Arr(0 To IIf(Limit = -1, lText - 1, Limit))
Elements = 0: ElemStart = 1
For N = 1 To lText
If InStr(DelimChars, Mid(Text, N, 1)) Then
Arr(Elements) = Mid(Text, ElemStart, N - ElemStart)
If IgnoreConsecutiveDelimiters Then
If Len(Arr(Elements)) > 0 Then Elements = Elements + 1
Else
Elements = Elements + 1
End If
ElemStart = N + 1
If Elements + 1 = Limit Then Exit For
End If
Next N
'Get the last token terminated by the end of the string into the array
If ElemStart <= lText Then Arr(Elements) = Mid(Text, ElemStart)
'Since the end of string counts as the terminating delimiter, if the last character
'was also a delimiter, we treat the two as consecutive, and so ignore the last elemnent
If IgnoreConsecutiveDelimiters Then If Len(Arr(Elements)) = 0 Then Elements = Elements - 1
ReDim Preserve Arr(0 To Elements) 'Chop off unused array elements
SplitMultiDelims = Arr
End Function

Which method to separate a long message?

I am facing problem when receiving a long message as below
40=1.22.50=0.002.60=35.
The system use the dot as separator while there is also decimal values for numeric value.
The desired output is
40=1.22
50=0.002
60=35
I am now using manual way to format the message. Hope to have a better way to overcome this.
Assuming you have one dot "." as the decimal position, and another "." that separates each element in the array. You can use the code below to read all values of the Long string into an array (Nums is the name of the array).
Option Explicit
Sub Seperate_DecimNumbers()
Dim Nums As Variant
Dim FullStr As String
Dim DotPosition As Integer
Dim i As Integer
' init array size to a large size , will redim it at the end to number of elements found
ReDim Nums(1 To 100)
FullStr = "40=1.22.50=0.002.60=35."
i = 1 ' init array elements counter
Do Until Len(FullStr) = 0
' call FindN function , searching for the 2nd "."
DotPosition = FindN(FullStr, ".", 2)
' unable to find 2 "." in the string >> last element in the array
If DotPosition = 0 Then
Nums(i) = FullStr
Exit Do
Else ' was able to find 2 "." in the string
Nums(i) = Left(FullStr, DotPosition - 1)
End If
i = i + 1
FullStr = Right(FullStr, Len(FullStr) - DotPosition)
Loop
' redim array back to maximum of numbers found in String
ReDim Preserve Nums(1 To i)
' place output start location from Range A2 and below (till number of elements in the array)
Range("A1").Offset(1, 0).Resize(UBound(Nums), 1).Value = Application.Transpose(Nums)
End Sub
Function FindN(sInputString As String, sFindWhat As String, N As Integer) As Integer
' this function find the Nth position of a certain character in a string
Dim J As Integer
Application.Volatile
FindN = 0
For J = 1 To N
FindN = InStr(FindN + 1, sInputString, sFindWhat)
If FindN = 0 Then ' unable to find the 2nd "." >> last appearance
Exit For
End If
Next
End Function
See result below:
Here's my take on the answer, which splits things on the = rather than the .. Doing it this way allows for input such as 40=1.22.50=0.002.60=35.70=120. (i.e. the part to the right of an = does not have to contain a ., it could be an integer.)
Sub SplitDotEqual()
Dim s As String
Dim a() As String
Dim i As Integer
Dim d As Integer
'Read from A1
s = Range("A1").Value
'Split on the "="
a = Split(s & ".", "=") ' include an extra "." to ensure that
' the final field is ended
For i = 0 To UBound(a) - 1
'Put the "=" back
a(i) = a(i) & "="
'Find the last "." before the next "="
d = InStrRev(a(i + 1), ".")
'Append everything prior to the "."
a(i) = a(i) & Left(a(i + 1), d - 1)
'Write to A2:Ax
Cells(i + 2, 1).Value = a(i)
'Strip off everything prior to the ".",
'leaving just the stuff prior to the "="
a(i + 1) = Mid(a(i + 1), d + 1)
Next
End Sub
Let's assume that every other dot is a separator. This code changes the odd-numbered dots into pipes and then parses on the pipes:
Sub parser()
Dim FlipFlop As Boolean, dot As String, pipe As String
Dim s As String, L As Long, i As Long, CH As String
dot = "."
pipe = "|"
s = Range("A1").Value
L = Len(s)
FlipFlop = True
For i = 1 To L
CH = Mid(s, i, 1)
If CH = dot Then
If FlipFlop Then
Else
Mid(s, i, 1) = pipe
End If
FlipFlop = Not FlipFlop
End If
Next i
msg = s & vbCrLf
ary = Split(s, pipe)
For Each a In ary
msg = msg & vbCrLf & a
Next a
MsgBox msg
End Sub
got more closer message and the code partially works.
8=TEST.1.2.9=248.35=D.49=MMUIJ.56=FGTUH.34=32998.50=MMTHUJ.57=AY/ABCDE.52=20161216-07:58:07.11=00708991.1=A-12345-

Resources