Read Text file to worksheet - excel

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

Related

Reading medium large .dat file with Excel VBA

Your support is really appreciated!
I am receiving a .dat file from a measuring tool, which is found hard to get in to excel.
I would like to do it without power query as well.
I do this in steps:
Step 1; convert dat file to "csv/txt" by removing duplicate spaces and replacing spaces with ";", also replacing "." with ",".
I would like to keep this format as several other tools tends to use similar format.
And from this I thought it would be fairly ok to import it, however...
First row of 11000 rows of .dat file:
1 1 -0.4200 -0.0550 0.1420 173 174 181 56.3 55.5 59.3 87 84 95 0.778 0 0 0
first row of the converted file, all rows below looks good as well.
1;1;-0,4260;-0,1500;0,0990;171;168;176;55,5;53,8;57,6;96;83;82;4,794;0;0;0
if I import this file with power query it seems ok.
Step 2:
When importing it with the code below, following occurs on line 660
from txt file
1;660;-1,0210;-0,0340;0,0470;169;164;176;54,6;51,2;57,2;15;96;63;0,782;0;0;0
from excel:
Debuging the shows following:
file:
format of the cell is "Numbers" and not "geeral" as for other numbers.
This seems to occure now and then, and typically when the number goes above -1,xx.
Code is found online, and is fairly quick.
I suspect that something happens when putting the two-dimensional variant array into the sheet
Dim Data As Variant 'Array for the file values
.
.
.
.
With Sheets(parSheetName)
'Delete any old content
.cells.ClearContents
'A range gets the same dimensions as the array
'and the array values are inserted in one operation.
.cells(4, 1).Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End With
End If
Option Explicit
'**************************************************************
' Imports CSV to sheet, following the generated numbers will be placed in a table.
'**************************************************************
Public Sub copyDataFromCsvFileToSheet(parFileName As String, _
parDelimiter As String, parSheetName As String)
Dim Data As Variant 'Array for the file values
Dim I As Long
Dim J As Long
Dim prt As String
'Function call - the file is read into the array
Data = getDataFromFile(parFileName, parDelimiter)
'If the array isn't empty it is inserted into
'the sheet in one swift operation.
If Not isArrayEmpty(Data) Then
'If you want to operate directly on the array,
'you can leave out the following lines.
ActiveWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count)).Name = parSheetName
'For I = 1 To 1000 'UBound(Data, 1)
'For J = 1 To 18 'UBound(Data, 2)
''prt = Data(I, J)
''Debug.Print prt
''ThisWorkbook.Worksheets(parSheetName).cells(I, J) = Data(I, J)
'Next J
'Next I
'Debug.Print "done"
'End If
With Sheets(parSheetName)
'Delete any old content
.cells.ClearContents
'A range gets the same dimensions as the array
'and the array values are inserted in one operation.
.cells(4, 1).Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End With
End If
'Call sbCreatTable(parSheetName)
End Sub
'**************************************************************
Private Function isArrayEmpty(parArray As Variant) As Boolean
'Returns False if not an array or a dynamic array
'that hasn't been initialised (ReDim) or
'deleted (Erase).
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then
isArrayEmpty = True
Exit Function
Else
isArrayEmpty = False
End If
End Function
Private Function getDataFromFile(parFileName As String, _
parDelimiter As String, _
Optional parExcludeCharacter As String = "") As Variant
'parFileName is the delimited file (csv, txt ...)
'parDelimiter is the separator, e.g. semicolon.
'The function returns an empty array, if the file
'is empty or cannot be opened.
'Number of columns is based on the line with most
'columns and not the first line.
'parExcludeCharacter: Some csv files have strings in
'quotations marks ("ABC"), and if parExcludeCharacter = """"
'quotation marks are removed.
Dim locLinesList() As Variant 'Array
Dim locData As Variant 'Array
Dim I As Long 'Counter
Dim J As Long 'Counter
Dim locNumRows As Long 'Nb of rows
Dim locNumCols As Long 'Nb of columns
Dim fso As Variant 'File system object
Dim ts As Variant 'File variable
Const REDIM_STEP = 10000 'Constant
'If this fails you need to reference Microsoft Scripting Runtime.
'You select this in "Tools" (VBA editor menu).
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
'Sets ts = the file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
'Initialise the array
ReDim locLinesList(1 To 1) As Variant
I = 0
'Loops through the file, counts the number of lines (rows)
'and finds the highest number of columns.
Do While Not ts.AtEndOfStream
'If the row number Mod 10000 = 0
'we redimension the array.
If I Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList _
(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
End If
locLinesList(I + 1) = Split(ts.ReadLine, parDelimiter)
J = UBound(locLinesList(I + 1), 1) 'Nb of columns in present row
'If the number of columns is then highest so far.
'the new number is saved.
If locNumCols < J Then locNumCols = J
I = I + 1
Loop
ts.Close 'Close file
locNumRows = I
'If number of rows is zero
If locNumRows = 0 Then Exit Function
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
'Copies the file values into an array.
'If parExcludeCharacter has a value,
'the characters are removed.
If parExcludeCharacter <> "" Then
For I = 1 To locNumRows
For J = 0 To UBound(locLinesList(I), 1)
If Left(locLinesList(I)(J), 1) = parExcludeCharacter Then
If Right(locLinesList(I)(J), 1) = parExcludeCharacter Then
locLinesList(I)(J) = _
Mid(locLinesList(I)(J), 2, Len(locLinesList(I)(J)) - 2)
Else
locLinesList(I)(J) = _
Right(locLinesList(I)(J), Len(locLinesList(I)(J)) - 1)
End If
ElseIf Right(locLinesList(I)(J), 1) = parExcludeCharacter Then
locLinesList(I)(J) = _
Left(locLinesList(I)(J), Len(locLinesList(I)(J)) - 1)
End If
locData(I, J + 1) = locLinesList(I)(J)
Next J
Next I
Else
For I = 1 To locNumRows
For J = 0 To UBound(locLinesList(I), 1)
locData(I, J + 1) = locLinesList(I)(J)
Next J
Next I
End If
getDataFromFile = locData
Exit Function
error_open_file: 'Returns empty Variant
unhandled_error: 'Returns empty Variant
End Function
Due to mentioned several measuring tools, the power query is un suited, and the control is better when using the ole way of doing it.
Solution:
Setting the variant to decimal when building the array
CDec(locLinesList(I)(J))
Thanks for your responce!

In Excel VBA, how could I compute sum of values which has a total limit that should not exceed $500, and then get corresponding product combination?

I have a table with two Columns Product and Price($).
Product
Price($)
A
100
B
400
C
350
D
50
E
515
F
140
I am trying to use vba to get combination of value of all products that will not exceed $500. I have been trying with this code and I am not sure how to proceed from this point on.
Sub getCombination()
Dim price As Long
Dim limit As Long
Dim i As Integer
Dim j As Integer
Dim combination As String
limit = 500
combination = ""
Range("B2").Activate
price = Range("B2").Value
For i = 1 To 6
For j = 1 To 6
If price <= limit Then
price = price + ActiveCell.Offset(j, 0).Value
combination = combination & ActiveCell.Offset(0, -1).Value & "," & ActiveCell.Offset(1, -1).Value
End If
Next j
Next i
ActiveCell.Offset(1, 0).Activate
MsgBox combination
End Sub
My Expected output is something like
A,B
A,C
A,C,D
B,D
C,F
A,D
C,D
(Please note: Not All output combinations are specified here!)
How should I proceed with the existing code? Or do I really have a better way for me to implement this?
Since the item can be used or not, that is a binary response. Using a binary number with the same number of digits as the number of items we can do all the combinations and do the testing:
Sub getCombination()
Dim rngArr As Variant
rngArr = ActiveSheet.Range("A2:B7")
Dim cnt As Long
cnt = 2 ^ UBound(rngArr, 1) - 1
Dim OutArray As Variant
ReDim OutArray(1 To cnt, 1 To 2)
Dim k As Long
k = 1
Dim i As Long
For i = 1 To cnt
Dim bin As String
bin = Application.Dec2Bin(i, UBound(rngArr, 1))
Dim delim As String
delim = ""
Dim j As Long
For j = 1 To UBound(rngArr, 1)
If Mid(bin, j, 1) = "1" Then
OutArray(k, 1) = OutArray(k, 1) & delim & rngArr(j, 1)
delim = ", "
OutArray(k, 2) = OutArray(k, 2) + rngArr(j, 2)
End If
Next j
If OutArray(k, 2) <= 500 Then
k = k + 1
Else
OutArray(k, 1) = ""
OutArray(k, 2) = 0
End If
Next i
Dim fnlarr As Variant
ReDim fnlarr(1 To k - 1)
For i = 1 To k - 1
fnlarr(i) = OutArray(i, 1)
Next i
Debug.Print Join(fnlarr, " | ")
End Sub

How to copy URL from specific cell using VBA

I need your help to get URL from a specific cell.
For an example assume the below is the cell data I am referring to.
Microsoft Teams meeting
Join on your computer or mobile app
Click here to join the meeting https://teams.microsoft.com/l/meetup-join/19%3ameeting_OWEzN2JmZmEtOTVmMS00ZDc4LThlNzQtNjQyNWM0ZjllODIx%40thread.v2/0?context=%7c%22Tid%22%3a%227a916015-20ae-4ad1-9170-eafd915e9272%22%2c%24Oid%22%3a%22b8ed972c-91b4-4fe1-a5d5-1410ea30a159%22%7d
Learn More https://aka.ms/JoinTeamsMeeting | Meeting options https://teams.microsoft.com/meetingOptions/?organizerId=b8ed972c-79b4-4fe1-a5d5-1410ea30a159&tenantId=7a916015-20ae-4ad1-9170-eefd915e9272&threadId=19_meeting_OWEzN2JmZmEtOTVmMS00ZDc4LThlNzQtNjQyNWM0ZjllODIx#thread.v2&messageId=0&language=en-US
So from above cell text i want to copy the first URL to another cell.
Request your guidance.
Please, try the next function:
Function extractURLs(strCell As String) As Variant
Dim frst As Long, lst As Long, arr, k As Long, sp As Long
Dim pos As Long, URLNo As Long, i As Long
'count existing number if URLs:
Do
pos = InStr(pos + 1, strCell, "https:")
If pos > 0 Then
URLNo = URLNo + 1
End If
Loop While pos > 0
If URLNo = 0 Then extractURLs = Array("Error"): Exit Function 'in case of no URL being found
ReDim arr(URLNo - 1) 'ReDim the array to keep the found URLs
For i = 1 To URLNo 'loop between the above occurrences found number
frst = InStr(frst + 1, strCell, "https:") 'determine the first occurrence for https: string
lst = InStr(frst, strCell, vbLf) 'determine the last occurrence (starting from frst) for end of line
If lst > 0 Then 'if the string is found:
sp = InStr(Mid(strCell, frst, lst - frst), " ") 'determine if a space exists in the string between first and last
If sp > 0 Then 'if it exists:
arr(k) = Mid(strCell, frst, sp): k = k + 1 'it returns the string up to the first space
Else
arr(k) = Mid(strCell, frst, lst - frst): k = k + 1 'if returns the string up to the end of line
End If
End If
Next i
extractURLs = arr 'return the array content
End Function
It can be tested like in such a code:
Sub testExtractURLs()
Dim strTest As String, arr, i As Long
strTest = ActiveCell.value
arr = extractURLs(strTest)
If UBound(arr) = 0 Then
If arr(0) = "Error" Then
MsgBox "No any URL could be found..."
Else
Debug.Print arr(0)
End If
Else
For i = 0 To UBound(arr)
Debug.Print arr(i)
Next i
End If
End Sub
Please, test it and send some feedback

VBA Excel: Feasible combination creator using single list of elements with no element repeating

I have the following Excel sheet which has random number combinations build using numbers from 2 to 50 in set of 3, 2 and 1 in Column A.
I am trying to build whole possible combinations between Column A elements such that the obtained combination doesn't have any repeating numbers in them and contains all the number from 2 to 50.
My current code starts from A2 and builds only a single combination set. It doesn't evaluate other possible combinations with starting element as in A2, it then goes to A3 and then builds only one combination set using A3. This step continues for A4,A5...
This is my current code.
Private Sub RP()
Dim lRowCount As Long
Dim temp As String, s As String
Dim arrLength As Long
Dim hasElement As Boolean
Dim plans() As String, currentPlan() As String
Dim locationCount As Long
Dim currentRoutes As String
Dim line As Long
Worksheets("Sheet1").Activate
Application.ActiveSheet.UsedRange
lRowCount = ActiveSheet.UsedRange.Rows.Count
locationCount = -1
line = 2
Debug.Print ("*********")
For K = 2 To lRowCount - 1
currentRoutes = ""
For i = K To lRowCount
s = ActiveSheet.Cells(i, 1)
Do
temp = s
s = Replace(s, " ", "")
Loop Until temp = s
currentPlan = Split(Trim(s), ",")
arrLength = UBound(currentPlan) - LBound(currentPlan) + 1
hasElement = False
If Len(Join(plans)) > 0 Then
For j = 0 To arrLength - 1
pos = Application.Match(currentPlan(j), plans, False)
If Not IsError(pos) Then
hasElement = True
Exit For
End If
Next j
End If
If Not hasElement Then
currentRoutes = currentRoutes & (Join(currentPlan, ",")) & " "
If Len(Join(plans)) > 0 Then
plans = Split(Join(plans, ",") & "," & Join(currentPlan, ","), ",")
Else
plans = currentPlan
End If
End If
Next i
If locationCount < 0 Then
locationCount = UBound(plans) - LBound(plans) + 1
End If
If (UBound(plans) - LBound(plans) + 1) < locationCount Then
Debug.Print ("Invalid selection")
Else
Debug.Print (Trim(currentRoutes))
Worksheets("Sheet1").Cells(line, 11) = currentRoutes
line = line + 1
End If
Erase plans
Debug.Print ("*********")
Next K
End Sub

Difficulty in finding end of row in VB 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 ;)

Resources