I want to find the position of a sub String in a String but facing some issues. Here is the code
Function findPos( Searchval As String, Output As String) As Long
Dim pos, i, count As Long
pos = InStr(1, content, searchVal, 0)
If pos = 0 Then
count = 0
Else
count = 1
End If
If pos > 0 Then
For i = 1 To pos
If Mid(content, i, 1) = "/" Then count = count + 1
Next i
End If
findPos=count
End Function
For eg: If output is "AA/AE_ABC/AE/CD" and if I searchVal is "AE" then I get output position as 2 which is wrong as I should get 3. I know that pos in code has to be modified somehow but can't figure it.
If you just want to find the position of the string then use this
Sub Sample()
Debug.Print findPos("AE", "AA/AE_ABC/AE/CD")
End Sub
Function findPos(Searchval As String, Output As String) As Long
findPos = InStr(1, Output, Searchval, 0)
End Function
BTW, the position is 4 and not 3
Edit: If you are looking for position after "/" then try this
Sub Sample()
Debug.Print findPos("AE", "AA/AE_ABC/AE/CD")
End Sub
Function findPos(Searchval As String, Output As String) As Long
Dim MyAr
Dim i As Long
'~~> Check if output has "/"
If InStr(1, Output, "/", 0) Then
'~~> Split it and store it in an array
MyAr = Split(Output, "/")
'~~> Loop through the array to find an exact match
For i = LBound(MyAr) To UBound(MyAr)
If MyAr(i) = Searchval Then
findPos = i + 1
Exit Function
End If
Next i
Else
'~~> Check if both Searchval and Output are same
If Output = Searchval Then findPos = 1
End If
End Function
Something like this should work for you, commented for clarity:
Function findPos(ByVal strFind As String, _
ByVal strContent As String, _
Optional ByVal sDelimiter As String = "/") As Long
'strFind is the substring you're searching for
'strContent is the string you're looking in for strFind
'Be default sDelimiter is '/' but it can be specified as something else
Dim varSection As Variant
Dim i As Long
'Check if strFind exists in strContent by itself with the delimiter
If InStr(1, sDelimiter & strContent & sDelimiter, sDelimiter & strFind & sDelimiter, vbTextCompare) > 0 Then
'It exists, loop through delimited sections of strContent to return the position
For Each varSection In Split(strContent, sDelimiter)
i = i + 1 'Increase section count
If varSection = strFind Then 'Check for match
'Match found, return position and exit for loop
findPos = i
Exit For
End If
Next varSection
Else
'No match found, return 0
findPos = 0
End If
End Function
Related
Does anyone knows how to higlight similar words within a single cell?
What I want to achieve is to find duplicates/similar words between < ; > in a cell.
example cell:
home;music;car;window;musician
desired result:
music in a word musician is hilglighted or the output is 'TRUE' in the next column if similar word like this has been found.
I was able to compare words between two columns but not within single cell.
So far I was able to create a formula to separate the words in the cell to have each range separate to work with.
Function IdDuplicates(rng As Range) As String
Dim StringtoAnalyze As Variant
Dim I As Integer
Dim J As Integer
Const minWordLen As Integer = 4
StringtoAnalyze = Split(UCase(rng.Value), ";")
For I = UBound(StringtoAnalyze) To 0 Step -1
If Len(StringtoAnalyze(I)) < minWordLen Then GoTo SkipA
For J = 0 To I - 1
If StringtoAnalyze(J) = StringtoAnalyze(I) Then
IdDuplicates = "TRUE"
GoTo SkipB
End If
Next J
SkipA:
Next I
IdDuplicates = "FALSE"
SkipB:
End Function
Any ideas?
This function returns either FALSE or a list of the similar words
Option Explicit
Function IdDuplicates(rng As Range) As String
Dim s As String, word, m As Object, i As Long
With CreateObject("VBScript.RegExp")
.IgnoreCase = True
.Global = True
s = Trim(rng.Value2)
For Each word In Split(s, ";")
.Pattern = word
Set m = .Execute(s)
If m.Count > 1 Then
IdDuplicates = IdDuplicates & "," & word
End If
Next
End With
If IdDuplicates = "" Then
IdDuplicates = "FALSE"
Else
IdDuplicates = Mid(IdDuplicates, 2) ' remove lead ,
End If
End Function
Match Partially in Delimited String
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a boolean indicating whether any of the substrings
' in a delimited string is contained in another substring.
' Example: 'music;car;musician' - 'music' is found in 'musician' - TRUE
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function MatchPart( _
ByVal DelimitedString As Variant, _
Optional ByVal StringDelimiter As String = ";") _
As Boolean
Dim S As String: S = CStr(DelimitedString)
Dim Substrings() As String
Substrings = Split(DelimitedString, StringDelimiter)
Dim sUpper As Long: sUpper = UBound(Substrings)
If sUpper < 1 Then Exit Function
Dim i As Long, j As Long, iPos As Long
Dim iSub As String, jSub As String
For i = 0 To sUpper - 1
iSub = Substrings(i)
For j = i + 1 To sUpper
jSub = Substrings(j)
'Debug.Print i, iSub, j, jSub
If Len(iSub) <= Len(jSub) Then
If InStr(1, jSub, iSub, vbTextCompare) > 0 Then
MatchPart = True
Exit Function
End If
Else
If InStr(1, iSub, jSub, vbTextCompare) > 0 Then
MatchPart = True
Exit Function
End If
End If
Next j
Next i
End Function
I want to make a function where I extract all words with length = 2 from a sentence. For example, if the sentence is "The Cat is brown", I want the result in the cell to be "is". If there are multiple words with length = 2, I want to keep these too. I have tried MID, RIGHT, LEFT, etc. These does not work as the position of the word is not always identical.
I have no clue how to do this in VBA, any suggestions are welcome :)
Thanks
I have made you a UDF which should work for what you want. You use it like so:
=ExtractWords(Cell to check, Optional number of letters)
By default it will check for 2 letter words but you can specify as well as shown above.
Here is the code. Place it into a module
Function ExtractWords(Cell As Range, Optional NumOfLetters As Integer)
Dim r As String, i As Long, CurrentString As String, FullString As String, m As String
If NumOfLetters = 0 Then NumOfLetters = 2
r = Cell.Value
For i = 1 To Len(r)
m = Mid(r, i, 1)
If Asc(UCase(m)) >= 65 And Asc(UCase(m)) <= 90 Or m = "-" Or m = "'" Then 'Accepts hyphen or single quote as part of the word
CurrentString = CurrentString & m
If i = Len(r) Then GoTo CheckLastWord
Else
CheckLastWord:
If Len(CurrentString) = NumOfLetters Then
If FullString = "" Then
FullString = CurrentString
Else
FullString = FullString & " " & CurrentString 'Change space if want another delimiter
End If
End If
CurrentString = ""
End If
Next i
If FullString = "" Then
ExtractWords = "N/A" 'If no words are found to contain the length required
Else
ExtractWords = FullString
End If
End Function
There are probably other ways to do it that may be easier or more efficient. This is just something I came up with.
Double Upper Case Occurrences
In Excel you can e.g. use it like this:
=getDUC(A1)
=getDUC(A1," ")
=getDUC(A1,",")
=getDUC(A1,"-")
The Code
Option Explicit
' In Excel:
Function getDUC( _
ByVal s As String, _
Optional ByVal Delimiter As String = ", ") _
As String
Dim arr As Variant
arr = DoubleUCaseToArray(s)
getDUC = Join(arr, Delimiter)
End Function
' In VBA:
Sub testDoubleUCaseToArray()
Dim CCodes As Variant: CCodes = Array("US,UKUs", "UkUS,UK", "kUSUKsUK")
Dim arr As Variant
Dim n As Long
For n = LBound(CCodes) To UBound(CCodes)
arr = DoubleUCaseToArray(CCodes(n))
Debug.Print Join(arr, ",")
Next n
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: From a specified string, returns all unique double upper case
' occurrences in a 1D (zero-based) array.
' Remarks: From the string 'USUk' it returns only 'US' (not `SU`).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DoubleUCaseToArray( _
ByVal s As String) _
As Variant
If Len(s) > 1 Then
With CreateObject("Scripting.Dictionary")
Dim cFirst As String * 1
Dim cSecond As String * 1
Dim n As Long
For n = 1 To Len(s) - 1
cFirst = Mid(s, n, 1)
If cFirst Like "[A-Z]" Then
cSecond = Mid(s, n + 1, 1)
If cSecond Like "[A-Z]" Then
.Item(cFirst & cSecond) = Empty
End If
n = n + 1
End If
Next n
If .Count > 0 Then
DoubleUCaseToArray = .Keys
End If
End With
End If
End Function
I currently have a function which can extract the cell reference using vbscript.regexp which is not something I am particularly familiar with, however for the most part it works. The idea is to populate a list with each of the references from a formula, containing the workbook name (if an external workbook), sheet name (if a different sheet to the one where the input cell is) and finally the cell being referenced.
For example, if my input cell has a formula of simply "=AA111" then my function when applied to this cell will output "AA111" (which I can then use to determine the page number of where this cell is. In a more complicated example, if my input cell has a formula of "=[WorkbookName]SheetNameA!AB222 + SheetNameB!AC333" then my function would return "[WorkbookName]SheetNameA!AB222" and "SheetNameB!AC333". I am then able to 'read' these strings by looking at the positions of the ']' symbol which denotes the end of the workbook reference (if any) or the '!' which denotes the end of the sheet reference (if any).
The code I am currently using is as follows;
Public Function CellRef(CellInput As Range) As String
CellRefDetector = "'?([a-zA-Z0-9\s\[\]\.])*'?!?\$?[A-Z]+\$?[0-9]+(:\$?[A-Z]+\$?[0-9]+)?"
With CreateObject("vbscript.regexp")
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = CellRefDetector
Set Results = .Execute(CellInput.Formula)
End With
I am using the regex string as developed here: https://www.get-digital-help.com/extract-cell-references-from-a-formula/
This works perfectly with the following issue; there are some characters (particularly operators) which I would like to be found and included within a workbook name or sheet name, but that I would like to not be found such that I can separate sums of different cells as different references. These include; + - _ / \ all of which may be found in the name of a workbook or sheet but I would also want to split up the reference in between different references.
For example, in my above code, a '+' operator in the workbook name will cause the workbook name to only be taken past that point. For example, "=[WorkbookName+Example]SheetNameC!AD222" would return "Example]Sheet_name_C!AD444" However, if I include a '+' operator in the regex line (i.e. included within my search of the regex), then the function will include something like "=AA111+AB222+AC333" all as one cell reference and not distinguish between them.
I hope I have given enough information for someone to provide assistance! Thanks in advance.
I don't know if this is any use to you, but a teacher friend of mine asked me for some code that would do more or less the same thing as you are asking.
The trick to those Workbook and Worksheet names which contain operator characters is that they'll always be bound by an inverted comma. So we can temporarily remove those items before identifying genuine operators.
There'll doubtless be an easier and quicker way to do it, but in the shortness of time, this is what I came up with for my friend:
Option Explicit
Public Function RangesInFormula(target As Range) As Variant
Dim str As String
Dim item As Variant, items As Variant
Dim addr As String, result As String
'Sense checking
If target.Cells.Count <> 1 Then
RangesInFormula = CVErr(xlErrRef)
Exit Function
End If
If Not target.HasFormula Then Exit Function
'Split formula into array.
items = SplitFormulaByOperators(target)
'Try to grab an address from each formula item.
For Each item In items
If Len(CStr(item)) > 0 Then
addr = RangeToString(CStr(item))
If Len(addr) > 0 Then
If Len(result) > 0 Then result = result & "|"
result = result & addr
End If
End If
Next
'Return the addresses if there are any.
If Len(result) > 0 Then
RangesInFormula = result
End If
End Function
Private Function RemoveTextBetween(startChar As String, endChar As String, sourceText As String) As String
Dim startPt As Long, endPt As Long
Dim tmp As String
tmp = sourceText
Do While True
endPt = InStr(tmp, endChar)
If startChar = endChar Then
endPt = InStr(endPt + 1, tmp, endChar)
End If
If endPt = 0 Then Exit Do
startPt = InStrRev(tmp, startChar, endPt - 1)
If startPt = 0 Then Exit Do
tmp = Left(tmp, startPt - 1) & Right(tmp, Len(tmp) - endPt)
Loop
RemoveTextBetween = tmp
End Function
Private Function SplitFormulaByOperators(target As Range) As Variant
Const OPERATORS = "+|-|*|/|%|^|>=|<=|<>|=|>|<|&|(|)"
Dim ws As Worksheet
Dim opr As Variant, ex As Variant
Dim tmp As String
Dim extractedList As Collection
Dim extracted(1) As String
Dim oprs() As String, result() As String
Dim i As Long
'Convert constant to array.
oprs = Split(OPERATORS, "|")
'Remove text between quotes
tmp = target.formula
tmp = RemoveTextBetween("""", """", tmp)
'Temporarily extract workbook and sheet names which have operators in them.
'They can be identified by bounding inverted commas.
Set extractedList = New Collection
Do While True
extracted(0) = ExtractTextBetween("'", "'", tmp, excludeMarkers:=False)
If Len(extracted(0)) = 0 Then Exit Do
extracted(1) = "|ex" & extractedList.Count & "|"
ex = Empty: On Error Resume Next
ex = extractedList(extracted(0)): On Error GoTo 0
If IsEmpty(ex) Then
extractedList.Add extracted, extracted(0)
tmp = Replace(tmp, extracted(0), extracted(1))
End If
Loop
'Replace the operators
For Each opr In oprs
tmp = Replace(tmp, opr, "|op|")
Next
result = Split(tmp, "|op|")
'Trim whitespace and commas.
For i = LBound(result) To UBound(result)
result(i) = TrimWhitespace(result(i), &H2C)
'Convert back to the extracted values.
For Each ex In extractedList
result(i) = Replace(result(i), ex(1), ex(0))
Next
Next
'Return the array.
SplitFormulaByOperators = result
End Function
Private Function ExtractTextBetween( _
startChar As String, _
endChar As String, _
sourceText As String, _
Optional acceptStartOfStringToEndChar As Boolean = False, _
Optional acceptStartCharToEndOfString As Boolean = False, _
Optional excludeMarkers As Boolean = True) As String
Dim i As Long, startPt As Long, endPt As Long
Dim tmp As String
For i = 1 To Len(sourceText)
tmp = Mid(sourceText, i, Len(startChar))
If startPt = 0 Then
If tmp = startChar Then
startPt = i
End If
Else
If tmp = endChar Then
endPt = i + Len(endChar) - 1
If excludeMarkers Then
startPt = startPt + Len(startChar)
endPt = endPt - Len(endChar)
End If
tmp = Mid(sourceText, startPt, endPt - startPt + 1)
ExtractTextBetween = tmp
Exit Function
End If
End If
Next
If startPt > 0 And endPt = 0 And acceptStartCharToEndOfString Then
If excludeMarkers Then
startPt = startPt + Len(startChar)
End If
tmp = Right(sourceText, Len(sourceText) - startPt + 1)
ExtractTextBetween = tmp
Exit Function
End If
If endPt > 0 And startPt = 0 And acceptStartOfStringToEndChar Then
If excludeMarkers Then
endPt = endPt - Len(endChar)
End If
tmp = Left(sourceText, endPt)
ExtractTextBetween = tmp
Exit Function
End If
End Function
Private Function RangeToString(addr As String) As String
Dim rng As Range
On Error Resume Next
Set rng = Evaluate(addr)
On Error GoTo 0
If rng Is Nothing Then Exit Function
'We have a range, so the address can be returned as valid reference.
RangeToString = addr
End Function
Private Function TrimWhitespace(txt As String, ParamArray additionals() As Variant) As String
Dim i As Long, j As Long, c As Long
Dim startPos As Long, endPos As Long
Dim whitespaces As Variant
Dim isWhitespace As Boolean
' List of whitespace characters.
whitespaces = Array( _
&H9, &HA, &HB, &HC, &HD, &H20, &H85, &HA0, _
&H1680, &H2000, &H2001, &H2002, &H2003, &H2004, &H2005, &H2006, _
&H2007, &H2008, &H2009, &H200A, &H2028, &H2029, &H202F, &H205F, _
&H3000, &H180E, &H200B, &H200C, &H200D, &H2060, &HFEFF)
' Find the first non-whitespace.
For i = 1 To Len(txt)
c = Asc(Mid(txt, i, 1))
isWhitespace = False
For j = LBound(whitespaces) To UBound(whitespaces)
If c = whitespaces(j) Then
isWhitespace = True
Exit For
End If
Next
For j = LBound(additionals) To UBound(additionals)
If c = additionals(j) Then
isWhitespace = True
Exit For
End If
Next
If Not isWhitespace Then
startPos = i
Exit For
End If
Next
' If there's no start position, return an empty string.
If startPos = 0 Then Exit Function
' Find the last non-whitespace.
For i = Len(txt) To startPos Step -1
c = Asc(Mid(txt, i, 1))
isWhitespace = False
For j = LBound(whitespaces) To UBound(whitespaces)
If c = whitespaces(j) Then
isWhitespace = True
Exit For
End If
Next
For j = LBound(additionals) To UBound(additionals)
If c = additionals(j) Then
isWhitespace = True
Exit For
End If
Next
If Not isWhitespace Then
endPos = i
Exit For
End If
Next
TrimWhitespace = Mid(txt, startPos, endPos - startPos + 1)
End Function
How to search for 2nd occurrence of a string in another string in VBA ?
For example , in below given string,the word "test" occurs twice.
this is a test to test
Simply do the search twice
Sub Demo()
Dim DataString As String
Dim SearchString As String
Dim i As Long
DataString = "this is a test to test"
SearchString = "test"
i = InStr(1, DataString, SearchString, vbTextCompare)
i = InStr(i + 1, DataString, SearchString, vbTextCompare)
Debug.Print "Second occurance starts at position " & i
End Sub
update
To just find the last occurrence then just
MsgBox InStrRev("this is a test to test", "test")
initial answer which handled less than 2 occurrences
A little ungainly but handles 1 or 0 occurences
Dim strIn As String
Dim strOut As String
Dim lngPos As Long
Dim lngPos2 As Long
strIn = "test"
strOut = "this is a test to test"
lngPos = InStr(strOut, strIn)
If lngPos > 0 Then
lngPos2 = InStr(lngPos + 1, strOut, strIn)
If lngPos2 > 0 Then MsgBox strIn & " at " & lngPos2
Else
MsgBox "No " & strIn
End If
To find the 2nd occurrence of a string, use the InStr function twice. Note that the substring for which you search could be a repeating character sequence like "dd". In this case you have to determine if you want to return 5 or 6 as the result of searching for "bb" in "abcdddd". That is, do you want to start searching for the second occurrence of "dd" at at the end of the first occurrence or at the second character of the first occurrence?
Private Sub ExampleFind2ndOccurrence()
Dim intFirst As Integer, intSecond As Integer
Dim searchThisString As String: searchThisString = "abcdddddefg"
Dim forThisSubString As String: forThisSubString = "dd"
' Find the first occurrence of forThisSubString
intFirst = InStr(1, searchThisString, forThisSubString, vbTextCompare)
' Find the second occurrence of forThisSubString
intSecond = InStr(1, Mid(searchThisString, intFirst + 1), forThisSubString, vbTextCompare)
If intSecond > 0 Then intSecond = intFirst + intSecond
Debug.Print "2nd occurrence occurs at character position "; intSecond
' Alternate method to find second occurrence of forThisSubString in the
' case where there can be no overlap
intSecond = InStr(1, Mid(searchThisString, intFirst + Len(forThisSubString)), forThisSubString, vbTextCompare)
If intSecond > 0 Then intSecond = intFirst + Len(forThisSubString) - 1 + intSecond
Debug.Print "Prohibbitting overlap, 2nd occurrence occurs at character position "; intSecond
End Sub
Find the Nth occurrence of a substring:
Public Function InStr2(ByVal IntStartPosition As Variant _
, ByVal Str As String _
, ByVal SubStr As String _
, Optional IntCompareMethod As Integer = vbTextCompare _
, Optional IntOccurrence As Integer = 1 _
, Optional BlnOverlapOK As Boolean = False)
' Find the IntOccurrence instance of SubStr in Str
' Parameters:
' IntStartPosition (Integer): the character position at which to start searching.
' (See docs for InStr)
' Str (String): the string to search. (See docs for InStr)
' SubStr (String): the substring to find in Str. (See docs for InStr)
' IntCompareMethod (integer): a VBA compare enumeration value. (See docs for InStr)
' IntOccurrence (integer): The number of instances of SubStr for which to search
' BlnOverlapOK (boolean): Is it okay for the Nth occurence of SubStr to overlap the
' N-1 occurrence?
' Returns the location of the occurence of the IntOccurrence instance of SubStr in Str
Dim s As String
Dim intCharPos As Integer
Dim cnt As Integer
Dim intStart As Integer
Dim i As Integer
' Initialize
If IsMissing(IntStartPosition) Then IntStartPosition = 1
intStart = IntStartPosition
Str = Mid(Str, intStart)
intCharPos = 1
cnt = 0
i = 1
Do While intCharPos <= Len(Str) And cnt < IntOccurrence
s = Mid(Str, intCharPos)
i = InStr(1, s, SubStr, IntCompareMethod)
If i = 0 Or i = Null Then
InStr2 = i
Exit Function
End If
cnt = cnt + 1
If BlnOverlapOK Or Len(SubStr) = 1 Or cnt = IntOccurrence Then
intCharPos = intCharPos + i
Else
intCharPos = intCharPos + i + Len(SubStr) - 1
End If
Loop
InStr2 = intCharPos - 1
End Function
Example of finding nth occurrence of substring:
Private Sub InStr2Example()
Dim i As Integer
Dim searchThisString As String: searchThisString = "abcddddddd"
'1234567890
Dim forThisSubString As String: forThisSubString = "dd"
i = InStr2(1, searchThisString, forThisSubString, vbTextCompare, 3, True)
Debug.Print "3rd occurrence occurs at character position "; i
i = InStr2(1, searchThisString, forThisSubString, vbTextCompare, 3, False)
Debug.Print "Prohibbitting overlap, 3rd occurrence occurs at character position "; i
End Sub
You will need to find where the first occurrence starts and then offset the search range accordingly.
A nested Mid/InStr function will do the trick:
Dim x As String, fVal As String
x = "test this is a test"
fVal = "test"
y = Mid$(Mid$(x, InStr(x, fVal) + Len(fVal)), InStr(Mid$(x, InStr(x, fVal) + Len(fVal)), fVal))
Debug.Print y
A flexible function to find any occurrence using Split() could be:
Function GetPosition(ByVal FullText As String, ByVal SearchString As String, ByVal occurrence As Long, Optional ByVal CaseSensitive As Boolean = False) As Long
'Purpose: get start position of a given search occurrence within fulltext
'[0]case sensitive? (case insensitive by default)
If Not CaseSensitive Then
FullText = LCase(FullText): SearchString = LCase(SearchString)
End If
'[1]split fulltext into substrings
Dim part: part = Split(FullText, SearchString) ' split fulltext
If occurrence < 1 Then Exit Function ' accept only positive occurrencies
If occurrence > UBound(part) Then Exit Function ' refuse too high occurrencies
'[2]add substrings plus searchstring lengths
Dim i As Long, n As Long ' counters
For i = 0 To occurrence - 1
n = n + Len(part(i)) ' add part lengths
Next
n = n + (occurrence - 1) * Len(SearchString) + 1
'[3]return search position of wanted occurrence
GetPosition = n
End Function
Example call
Sub Test()
Dim s As String: s = "this is a test to test to test" ' (three occurrencies of "test")
Dim i As Long
For i = 1 To 4
Debug.Print "Occurrence " & i, "starts at position " & GetPosition(s, "tEst", i)
Next
End Sub
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 ;)