VBA Exact Text Match - vba

I am attempting to pull a column of letter codes using InStr from existing text files. I would like to allow this macro to be flexible enough to allow the option to manually input the letter code being searched.
Where I am running into an issue is when common numbers are in the letter code (i.e. C4 and C45). Originally the code was written to search for 2 specific letter codes, and I was hoping to be able to replace those 2 identifiers with a link to 2 cells.
No such luck, as I keep getting responses that are not exact. Please see the code below:
Private Sub CmdLettersGetfile_Click()
Dim objFSO As Object
Dim myDir As String, myList()
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim sFolder As String
Dim fd As Office.FileDialog
Dim row As Long
Dim row1 As Long
Dim FCount As Integer
Dim FCount1 As Integer
Dim Val As String
Dim Pos As Integer
Dim Last1 As Long 'Mark the last row
Dim Start2 As Long
Dim Last2 As Long 'Mark the last row
Set fd = Application.FileDialog(msoFileDialogFilePicker)
For Each cn In ThisWorkbook.Connections
cn.Delete
Next cn
With ActiveSheet
Lastrow = Sheets("MAIN").Cells(.Rows.Count, "E").End(xlUp).row
End With
'
Worksheets("REPORT").Range("A6:AA1000000").ClearContents
Worksheets("REPORT").Range("A6:AA1000000").ClearFormats
row1 = 6 'Start of REPORT ROW
For row = 12 To Lastrow
sFile = Worksheets("MAIN").Cells(row, "E").Value
Pos = InStr(1, sFile, "org")
If Pos = 0 Then
Val = Worksheets("MAIN").Cells(9, "H")
Else
Val = Worksheets("MAIN").Cells(10, "H")
End If
Pos = 0
Dim strFilename As String
Dim strTextLine As String
Dim iFile As Integer
iFile = FreeFile
strFilename = folderName & "\" & sFile
Open strFilename For Input As #iFile
Last1 = 0
Last2 = 0
Do Until EOF(1)
Line Input #1, strTextLine
FCount = FCount
Pos = InStr(1, strTextLine, Val)
I cleaned up some of the irrelevant code in an attempt to save space and focus on the lines where I am having the issue.
********Update (26-Apr-2018 # 18:12 EST):
When I tried to format the Val to be one uppercase letter and 2 numbers
Dim Val As String: Val = "([A-Z]{1})([0-9]{1})([0-9]{1})"
I get the following:
Resulting data
Column I is the letter code that I need to get narrowed down.
*********Update 2 (27-Apr-2018 # 14:37 EST):
Expanded resulting data
I was able to mass redact what I needed to. I hope this offers more insight into what I'm looking to do.

Related

How to get the number of lines of data in CSV file in VBA

I tried to get the number of lines of data in several CSV files in VBA.
Here is the code.
Sub Woo_Products()
Dim fso As New FileSystemObject
Dim flds As Folders
Dim fls As Files
Dim strText As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim extfind As String
Dim FilePath As String
Dim sLineOfText As String
On Error Resume Next
Workbooks.Open Filename:="F:\Work\scrape\" & "woocommerce-products.csv", UpdateLinks:=3
Set fls = fso.getfolder("C:\Users\star\Downloads").Files
k = 2
For Each f In fls
strText = f.Name
extfind = Right$(strText, Len(strText) - InStrRev(strText, "."))
If extfind = "csv" Then
FilePath = "C:\Users\star\Downloads\" & strText
Open FilePath For Input As #1
i = 0
Do Until EOF(1)
Line Input #1, sLineOfText
If sLineOfText <> "" Then i = i + 1
Loop
Close #1
End If
Next
Windows("woocommerce-products.csv").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
But I am getting the same count for each file.
Of course, each file has different lines of data.
Hope to help me for this.
If all you need is a line count, I would write a function to return the count.
Function getFileLineCount(FullFileName As String, Optional LineDelimiter As String = vbNewLine) As Long
Dim text As String
Dim fileNo As Integer, n As Long
fileNo = FreeFile
Open FullFileName For Input As #fileNo
Do Until EOF(1)
Line Input #1, text
n = n + 1
Loop
Close #fileNo
getFileLineCount = n
End Function
Another approach using FileSystemObject:
Public Function GetLineCount(ByVal Path As String) As Long
With CreateObject("Scripting.FileSystemObject")
GetLineCount = UBound(Split(.OpenTextFile(Path, 1).ReadAll, vbNewLine)) + 1
End With
End Function
You'll need to add the references (Tools --> References)
Microsoft Scripting Runtime
Microsoft VBScript Regular Expressions 5.5
This will count "Return & NewLine" characters in the file.
Private Function LineCount(ByVal PathFile As String) As Long
Dim sData As String
Dim oFile As New FileSystemObject
sData = oFile.OpenTextFile(PathFile, ForReading).ReadAll
Dim oRegX As New RegExp
oRegX.Pattern = "\r\n"
oRegX.Global = True
LineCount = oRegX.Execute(sData).Count + 1
Set oRegX = Nothing
Set oFile = Nothing
End Function
i = ActiveWorkbook.ActiveSheet.Cells(ActiveWorkbook.ActiveSheet.Rows.Count, 1).End(xlUp).Row
It's working so well.

VBA Excel: for each results into cells? counter not working?

I´m creating a macro that crawls into subfolders and retrieve the name of some files. I used code from this answer to another question and works fine to get the results into the immediate window, but I want to get them into cells, as a list. What I get is just the result of the first iteration.
What I´m trying to do might be obvious, but I swear I tried and couldn´t find the answer by myself. For the record, I´m just starting to code.
My code here. The important part comes at the end, in Sub ListFiles(fld As Object, Mask As String).
Option Explicit
Sub Retrieve_Info()
Dim strPath As Variant
Dim pasta_destino As Range
Dim fle As String
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Set pasta_destino = ThisWorkbook.Worksheets("VINCULATOR").Range("pasta_destino")
strPath = Application.GetOpenFilename _
(Title:="Selecione o arquivo.xlsx", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If Not strPath = False Then
pasta_destino = strPath
fle = Dir(strPath)
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder(Replace(strPath, fle, ""))
Mask = "*.xlsx"
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
Next
End If
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim fl As Object 'File
Dim vrow As Integer
Dim vinculadas As Range
Dim n_vinc As Range
Set vinculadas = ThisWorkbook.Worksheets("VINCULATOR").Range("vinculadas")
Set n_vinc = ThisWorkbook.Worksheets("VINCULATOR").Range("n_vinc")
vrow = 0
For Each fl In fld.Files
If fl.Name Like Mask And InStr(fl.Name, "completo") = 0 Then
vrow = vrow + 1
vinculadas.Cells(vrow, 1) = fld.Path & "\" & fl.Name
End If
Next
n_vinc = vrow
End Sub
Please, help!
I have taken a slightly different approach which might be easier for you to follow in addition to executing faster. Please try this.
Sub SpecifyFolder()
' 10 Dec 2017
Dim Fd As FileDialog
Dim PathName As String
Dim Fso As Object
Dim Fold As Object, SubFold As Object
Dim i As Long
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
With Fd
.ButtonName = "Select"
.InitialView = msoFileDialogViewList
.InitialFileName = "C:\My Documents\" ' set as required
.Show
If .SelectedItems.Count Then
PathName = .SelectedItems(1)
Else
Exit Sub ' user cancelled
End If
End With
Set Fd = Nothing
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fold = Fso.GetFolder(PathName)
ListFiles Fold, "*.xlsx"
For Each SubFold In Fold.SubFolders
ListFiles SubFold, "*.xlsx"
Next SubFold
Set Fso = Nothing
End Sub
Sub ListFiles(Fold As Object, _
Mask As String)
' 10 Dec 2017
Dim Fun() As String ' file list
Dim Rng As Range
Dim Fn As String ' file name
Dim i As Long ' array index
ReDim Fun(1 To 1000) ' maximum number of expected files in one folder
Fn = Dir(Fold.Path & "\")
Do While Len(Fn)
If Fn Like Mask And InStr(Fn, "completo") = 0 Then
i = i + 1
Fun(i) = Fold.Path & "\" & Fn
End If
Fn = Dir
Loop
If i Then
ReDim Preserve Fun(1 To i)
With ThisWorkbook.Worksheets("VINCULATOR")
' specify the column in which to write (here "C")
i = .Cells(.Rows.Count, "C").End(xlUp).Row
Set Rng = .Cells(i + 1, "C").Resize(UBound(Fun), 1)
Application.ScreenUpdating = False
Rng.Value = Application.Transpose(Fun)
Application.ScreenUpdating = True
End With
End If
End Sub
As you see, I have dispensed with specifying a target range, just the sheet and the column (I chose column C; please change as required in the ListFiles sub). Note that the code appends new lists to the existing content of the indicated column.
There are two things the code doesn't do to my entire satisfaction. One, it doesn't write to the first row of an empty column C. Instead, it leaves the first row blank. You might actually like that. Two, It doesn't do sub-subfolders. File names are extracted only from the selected folder and its immediate subfolders. Additional programming would be required for either additional feature, if required.
Finally, I admit that I didn't test for correct transfer of the lists to the worksheet. I think it works correctly but you should check that the first and last names are listed in your worksheet column. They are extracted from the folder but perhaps their omission when writing to the sheet would be a typical error to occur in this particular method.

Parsing a byte array with VBA using MS Access

I have a 100 million character text file that I'm trying to import into an MS Access database. The file does not have any linefeeds so it is just one giant line of text. I tried loading it into a string variable but that did not work because of the size. I then successfully loaded it into a byte array, but I'm unsure of how to parse it the way I need it. The file has fixed length records, but has more than one type of record. One type may be 180 characters of data and 220 characters of filler, and another may be 100 characters of data and 300 characters of filler. I would like to the different record types into separate tables. I was thinking of rewriting the data to a new text file in 400 character chunks, and then maybe using Trim to get just the data I need with no filler. From there I could test the line length and import.
Here is what I have, but it does not work.
Public Sub modMain_ParseAQTFiles()
Dim bytFile(400) As Byte
Dim intFileIn As Integer
Dim intFileOut As Integer
Dim intFileOut1 As Integer
Dim intFileOut2 As Integer
Dim intFFIn As Integer
Dim intFFOut As Integer
Dim lngBytePos As Long
Dim dblStartChar As Double
Dim lngNoRecs As Long
Dim lngIndex As Long
Dim strFileIn As String
Dim strFileOut1 As String
Dim strFileOut2 As String
Dim strLineOfText As String
Dim strTextLine As String
Dim strUserName As String
'Get username
strUserName = Environ("Username")
'Set file paths
strFileIn = "C:\Users\" & strUserName & "\Desktop\Pooltalk\aqt.txt"
strFileOut1 = "C:\Users\" & strUserName & "\ Desktop\Pooltalk\ AQT_Quartiles_Header-out.txt"
strFileOut2 = "C:\Users\" & strUserName & "\Desktop\Pooltalk \AQT_Quartiles_Detail-out.txt"
'Reads data into byte array
intFFIn = FreeFile
intFFOut = FreeFile
dblStartChar = 1
Open strFileIn For Binary Access Read As #intFFIn
lngNoRecs = LOF(intFFIn) / 400
For lngIndex = 1 To lngNoRecs
Get #intFFIn, dblStartChar, bytFile
strLineOfText = StrConv(bytFile, vbFromUnicode)
Open strFileOut For Binary Access Write As #intFFOut
Put intFFOut, dblStartChar, strLineOfText & vbCrLf
Debug.Print strLineOfText
dblStartChar = dblStartChar + 400
Next lngIndex
Close #intFFIn
Close #intFFOut
End Sub
I would be happy to hear if anyone has any advice to get this working. Thanks.
EDIT:
Here is one record type:
1004569 AS20170431360FCE319840701
34 characters of data and 366 blanks
Here is the second record type:
200456906875{06875{06875{06875{06875{06875{07I07I07I07I07I07I40B40B40B40B40B40B0000630000{0000630000{0000630000{0000630000{0000630000{0000630000{48{48{48{48{48{48{05926{05926{05926{05926{05926{05926{01250{01250{01250{01250{01250{01250{06875{06875{06875{06875{06875{06875{16875{16875{16875{16875{16875{16875{
307 characters and 93 blanks.
Here is my final code:
Public Sub modMain_ParseAQTFiles()
Dim intFileIn As Integer
Dim intFileOut1 As Integer
Dim intFFIn As Integer
Dim intFFOut As Integer
Dim lngNoRecs As Long
Dim lngIndex As Long
Dim strFileIn As String
Dim strFileOut1 As String
Dim strUserName As String
Dim strRecord As String
Dim dblStartChar As Double
Dim lngCharNo As Long
strUserName = Environ("Username")
'Set file paths
strFileIn = "C:\Users\" & strUserName & "\Desktop\Pooltalk\aqt.txt"
strFileOut1 = "C:\Users\" & strUserName & "\Desktop\Pooltalk\AQT_Parsed.txt"
strRecord = Space$(400)
dblStartChar = 1
'Reads data into byte array
intFFIn = FreeFile
Open strFileIn For Binary Access Read As #intFFIn
intFFOut = FreeFile
Open strFileOut1 For Binary Access Write As #intFFOut
'Find number of records
lngNoRecs = LOF(intFFIn) / 400
For lngIndex = 1 To lngNoRecs
Get #intFFIn, dblStartChar, strRecord
strRecord = Trim(strRecord)
Put intFFOut, , strRecord & vbCrLf
dblStartChar = dblStartChar + 400
strRecord = Space$(400)
Next lngIndex
Close #intFFIn
Close #intFFOut
MsgBox "Done!"
End Sub
If all records are 400 characters long, I would read them directly into a string variable of that length.
Dim strRecord As String
Dim x As Long
' Get reads as many characters as are in the target variable
strRecord = Space$(400)
Get #intFFIn, dblStartChar, strRecord
' Find first 0-byte character
x = Instr(strRecord, Chr$(0))
' and trim off the fillers
strRecord = Left$(strRecord, x-1)
See https://msdn.microsoft.com/VBA/Language-Reference-VBA/articles/get-statement at the bottom (before the example).

How to read text file into an array in vba

I have a text file with 1000 data entries (only integers).There is one entry per line in the text file. I was wondering how to transfer that data into an array in VBA.
Thank you for taking the time to respond.
Also we can do this without looping:
Sub Test()
Dim FSO As Object, MyFile As Object
Dim FileName As String, Arr As Variant
FileName = "C:\Test\Test.txt" ' change this to your text file full name
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
Arr = Split(MyFile.ReadAll, vbNewLine) ' Arr is zero-based array
'For test
'Fill column A from this Array Arr
Range("A1").Resize(UBound(Arr) + 1, 1).Value = Application.Transpose(Arr)
End Sub
Just save the path to your text file into a variable called FilePath and run this code block.
Dim arInt(1 to 1000) as Integer
Dim intCount as Integer
Set objFSO = CreateObject("Scripting.FileSystemObject")
With = objFSO.OpenTextFile(FilePath, ForReading)
intCount = 1
Do While .EOF = False AND intCount < 1001
arInt(intCount) = Val(.readline)
intCount = intCount + 1
Loop
The Val function turns the string into an number value and then vba casts it to an integer for you.
Afterwards, you have 100 int values in an array.
The code will stop once the file is compete or the array has 1000 values in it.

Reading data from multiple text files (EOF, Do-Until)

I want my macros to read certain lines from each text files (saved in a server folder) but so far, I can only get the macros to return the correct values for from the first text file...
I think it's because I don't really understand the 'Open xxx for input as #1' command... here is the macros:
Public CurrCell As Range
Public noLines As Integer
Sub NextCell()
Dim myFile As String
noLines = InputBox("Enter the number of TRs to add")
Range("A1").Activate
For Each CurrCell In Range(Cells(2, 1), Cells(noLines + 1, 1))
myFile = Application.GetOpenFilename()
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = myFile
Next CurrCell
End Sub
Sub GrabData()
Dim myFileName As String
Dim text As String
Dim textline As String
Dim Incidental As Integer
Dim TotalAccom As Integer
Dim Incidental_value As String
Dim TotalAccom_value As String
Dim i As Integer
For i = 1 To noLines
myFileName = Cells(i + 1, 1)
Open myFileName For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
Incidental = InStr(text, "INCIDENTAL ALLOWANCE")
Cells(i + 1, 2).Value = Mid(text, Incidental + 22, 5)
Next i
End Sub
The first sub is to ask users to enter and select how many text files they want to read, and the second sub is suppose to bring back the correct values for each text file.
Thanks in advance!!!
You may want to try this:
Public noLines As Long ' Use Public if this is to be accessed by another Module
Sub NextCell()
Dim i As Long, oRng As Range
noLines = CLng(InputBox("Enter the number of TRs to add"))
' First store all the filenames, store them below A1
Set oRng = Range("A1")
For i = 1 To noLines
oRng.Offset(i, 0).Value = Application.GetOpenFilename()
Next
Set oRng = Nothing
' Then invoke the sub "GrabData"
GrabData
End Sub
Sub GrabData()
Const sMarker = "INCIDENTAL ALLOWANCE"
Dim i As Long, oRng As Range
'Dim myFileName As String
Dim text As String
Dim textline As String
Dim Incidental As Long
'Dim TotalAccom As Integer
'Dim Incidental_value As String
'Dim TotalAccom_value As String
Set oRng = Range("A1")
For i = 1 To noLines
text = "" ' Reset the text to blank!
' Now go through the list of filenames stored below A1
Open oRng.Offset(i, 0).Value For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
' Get location of text after sMarker
Incidental = InStr(text, sMarker) + Len(sMarker) + 2
' Store 5 characters of text after sMarker to column C
oRng.Offset(i, 2).Value = Mid(text, Incidental, 5)
Next i
Set oRng = Nothing
End Sub