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

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

Related

VBA for copying multiple columns from different workbooks to be in columns next to each other

I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub

VBA- Import Multiple CSV to a Sheet, Remove Certain Rows/Columns

I am completely new to VBA, but I have CSV files(same format for all of them), and I want to import them to a single sheet on Excel. I was able to read the CSV file according to this code:
Sub R_AnalysisMerger()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles() As Variant
Dim NFile As Long
Dim FileName As String
Dim ws As Worksheet, vDB As Variant, rngT As Range
Application.ScreenUpdating = False
'Selects the CSV files as SELECTED FILES
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.Clear 'Clears current worksheet
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True) 'Selects csv files
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
With WSA
vDB = .UsedRange
Set rngT = ws.Range("a" & Rows.count).End(xlUp)(2)
If rngT.Row = 2 Then Set rngT = ws.Range("A1")
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
bookList.Close (0)
End With
Next
Application.ScreenUpdating = True
ws.Range("A1").Select
But I have additional requirements:
Skip the first column.
Skip the first four rows.
Remove a certain String from each word in the fifth row.
Im used to java, and usually I would read each line with a "for" loop and set "if" statements to skip the first row and four columns and remove the string from each string if it was present.
I don't know how to do this with this code. From what I understand it just copies the whole CSV file into the sheet?
This solution is based on reading CSV as textstream. I have tried to include feature that makes possible most all things like selecting columns, Rows and so on.
Sub ImportCSV()
Dim fso As New IWshRuntimeLibrary.FileSystemObject
Dim txtStream As IWshRuntimeLibrary.TextStream
Dim files As IWshRuntimeLibrary.files
Dim file As IWshRuntimeLibrary.file
Dim txtLine As String
Dim lineCount As Integer
Dim lastRow As Integer
Dim lineCol As Variant
Dim rng As Range
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).usedRange.Delete
Set rng = ThisWorkbook.Sheets(1).usedRange
lastRow = 1
Set files = fso.GetFolder("path\folder").files
For Each file In files
If file.Name Like "*.csv" Then
Set txtStream = file.OpenAsTextStream(ForReading, TristateUseDefault)
txtStream.SkipLine ' skip first line, since it containes headers
lineCount = 1
Do
txtLine = txtStream.ReadLine
If lineCount = 5 Then
txtLine = Replace(txtLine, "stringToReplace", "StringToReplcaeWith") ' replace certain string from words in 5'th row
End If
lineCount = lineCount + 1
lineCol = sliceStr(Split(txtLine, ";"), startIdx:=4) ' slice the array so to skip four first columns
For iCol = 0 To UBound(lineCol) ' write columns to last row
rng(lastRow, iCol + 1).Value = lineCol(iCol)
Next iCol
lastRow = lastRow + 1
'Debug.Print Join(lineCol, ";") ' debug
Loop Until txtStream.AtEndOfStream
End If
Next file
Application.ScreenUpdating = True
End Sub
This is the slicer function
Function sliceStr(arr As Variant, startIdx As Integer, Optional stopIdx As Integer = 0) As String()
If stopIdx = 0 Then
stopIdx = UBound(arr)
End If
Dim tempArrStr() As String
ReDim tempArrStr(stopIdx - startIdx)
Dim counter As Integer
counter = 0
For i = startIdx To stopIdx
tempArrStr(counter) = arr(i)
counter = counter + 1
Next
sliceStr = tempArrStr
End Function
I just did a simple test and the code below seems to work. Give it a go, and feedback.
Sub Demo()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Application.ScreenUpdating = False
Dim newWS As Worksheet
Set newWS = Sheets.Add(before:=Sheets(1))
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder("C:\Users\ryans\OneDrive\Desktop\output\") ' <-- use your FileDialog code here
Mask = "*.csv"
'Debug.Print fldStart.Path & ""
ListFiles fldStart, Mask
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
ListFolders fld, Mask
Next
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim L As Long, t As Long, i As Long
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For i = 1 To L
Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True
Set WB = ActiveWorkbook
lrow = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
WB.Sheets(1).Range("B4:E" & lrow).Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = True
End Sub
Sub ListFolders(fldStart As Object, Mask As String)
Dim fld As Object 'Folder
For Each fld In fldStart.SubFolders
'Debug.Print fld.Path & ""
ListFiles fld, Mask
ListFolders fld, Mask
Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim t As Long
Dim fl As Object 'File
For Each fl In fld.Files
If fl.Name Like Mask Then
t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
'Debug.Print fld.Path & "" & fl.Name
If Sheets(1).Cells(1, 1) = "" Then
Sheets(1).Cells(1, 1) = fld.Path & "\" & fl.Name
Else
Sheets(1).Cells(t, 1) = fld.Path & "\" & fl.Name
End If
End If
Next
End Sub

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 Exact Text Match

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.

Excel 2013: VBA create a range from X number of columns and save as a text file

So on my "sheet1" I have data in columns A, B, C, D, E, F
I would like VBA code to combine the 1st (A), 3rd(C) and 5th (E) column and save it to a comma separated text file.
I have:
Option Explicit
Public Sub ExcelRowsToCSV()
Dim iPtr As Integer
Dim sFileName As String
Dim intFH As Integer
Dim aRange As Range
Dim iLastColumn As Integer
Dim oCell As Range
Dim iRec As Long
Dim lenth As String
Set aRange = Range("A1:C11")
iLastColumn = aRange.Column + aRange.Columns.Count - 1
iPtr = InStrRev(ActiveWorkbook.FullName, ".")
sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".txt"
sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="TXT (Comma delimited) (*.txt), *.txt")
If sFileName = "False" Then Exit Sub
Close
intFH = FreeFile()
Open sFileName For Output As intFH
iRec = 0
For Each oCell In aRange
If oCell.Column = iLastColumn Then
Print #intFH, oCell.Value
iRec = iRec + 1
Else
Print #intFH, oCell.Value; ",";
iRec = iRec + 1
End If
Next oCell
Close intFH
MsgBox "Finished: " & CStr(iRec) & " records written to " _
& sFileName & Space(10), vbOKOnly + vbInformation
End Sub
This works but only if the range declared has columns that lay right next to each other.
The fastest way is to copy the worksheet as a new workbook and then delete unnecessary columns and then save the file as csv. This will not affect the original file as well.
For example (TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Copy the sheet as a new workbook
ws.Copy
ActiveSheet.Range("D:D,B:B,F:F").Delete Shift:=xlToLeft
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\Sample.Csv", FileFormat:=xlCSV
ActiveWorkbook.Close (False)
Application.DisplayAlerts = True
End Sub
try changing your for each to this: (untested, but hope you get the idea)
dim str as string
For i= 1 to arange.rows
str=""
for j=1 to arange.columns
str=str & ","
next
Print #intFH, str
Next