vba define range ending text - vba

I'm trying to process a data file and export each section to a separate text file. I can specify a range to export without issue (A1:A58) but I never know how many lines I'll need so it should be dynamic. For example, sheet1 will export 58 rows because row 1 will always start the range (A1) and 58 (A58) contains the text "Referring" indicating the end of that record. Then, those rows will be deleted. The next record will start with specific text "NewRecord" (A1) and complete with the words "Referring" again.
Sub ExportRange()
Dim c As Range, r As Range
Dim output As String
Dim MyFolder As String
Dim MyFile As String
Dim i As Long
Dim MyOldFile As String
Dim MyNewFile As String
MyFolder = "C:\Users\profile\Documents\test"
MyFile = Dir(MyFolder & "\text.txt")
i = i + 1
MyOldFile = MyFolder & "\" & MyFile
MyNewFile = MyFolder & "\" & Sheets("Sheet1").Range("B20") & "_" & i & ".txt"
For Each r In Range("A1:A37").Rows
For Each c In r.Cells
output = output & "," & c.Value
Next c
output = output & vbNewLine
Next r
Open "C:\Users\profile\Documents\test\Text.txt" For Output As #1
Print #1, output
Close
Name MyOldFile As MyNewFile
MyFile = Dir
Close
End Sub

This will find the first row that contains "Referring" searching from the top down and create a range from it that is used in the For loop.
Sub ExportRange()
Dim c As Range, r As Range, LoopRange as Range
Dim output As String
Dim MyFolder As String
Dim MyFile As String
Dim i As Long
Dim MyOldFile As String
Dim MyNewFile As String
Set LoopRange = Range("A1", Cells(Range("A:A").Find(what:="Referring", after:=Range("A1"), searchdirection:=xlNext).Row, "A"))
MyFolder = "C:\Users\profile\Documents\test"
MyFile = Dir(MyFolder & "\text.txt")
i = i + 1
MyOldFile = MyFolder & "\" & MyFile
MyNewFile = MyFolder & "\" & Sheets("Sheet1").Range("B20") & "_" & i & ".txt"
For Each r In LoopRange.Rows
For Each c In r.Cells
output = output & "," & c.Value
Next c
output = output & vbNewLine
Next r
Open "C:\Users\profile\Documents\test\Text.txt" For Output As #1
Print #1, output
Close
Name MyOldFile As MyNewFile
MyFile = Dir
Close
End Sub

Related

VBA code:Save the fillter data to txt file

VBA code: help me with, I want to save the fillter data to txt file.
Sub Intemp()
Dim arr, i As Long
Dim FPath As String
FPath = ThisWorkbook.Path & "\" & "text" & ".txt"
Application.CutCopyMode = False
arr = Sheet5.Range("B1:C" & [B100000].End(xlUp).Row)
Open FPath For Output As #1
For i = 1 To UBound(arr)
Print #1, arr(i, 1) & vbTab & arr(i, 2)
Next i
Close #1
End Sub
If you want to assign your filtered values to an array, an easy way to do that would be to use advanced filtering and filter into another area of the worksheet and assign your values there.
But a simple approach that will get you started is to just loop your rows in your range, if the row is hidden, then move on - otherwise, print the data to your text document.
Dim rng As Range, r As Long
Set rng = Sheet5.Range("B1:C" & [B100000].End(xlUp).Row)
Dim FPath As String
FPath = ThisWorkbook.Path & "\" & "text" & ".txt"
Application.CutCopyMode = False
Open FPath For Output As #1
With Sheet5
For r = rng.Row To rng.Rows.Count + rng.Row - 1
If Not .Rows(r).Hidden Then
Print #1, .Cells(r, 1) & vbTab & .Cells(r, 2)
End If
Next
End With
Close #1

Call a macro from a button in sheet 1 and write some data in sheet 2

I am trying to call the below code by using a button from sheet Homepage and expecting it to write data in sheet Logs . However when I do that, the data is getting written in the same sheet where the macro is called from.
Below is my code:
Sub MyRenamePDF()
Dim MyFolder As String
Dim MyFile As String
Dim i As Long
Dim MyOldFile As String
Dim MyNewFile As String
Dim dt As String
Dim FSO As Object
Dim rng As Range
Dim input_file As String
Dim output_file As String
dt = Format(Now(), "YYYY_MM_DD_HH_MM")
Set FSO = CreateObject("Scripting.Filesystemobject")
MyFolder = "D:\test\"
TargetFolder = "D:\output\"
MyFile = Dir(MyFolder & "\*.pdf")
Do While MyFile <> ""
MyOldFile = MyFolder & "\" & MyFile
MyNewFile = MyFolder & "\" & "0001" & "_" & dt & "_" & MyFile
Name MyOldFile As MyNewFile
output_file = FSO.GetFileName(MyNewFile)
With ThisWorkbook.Worksheets("Logs")
Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = output_file
Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = MyFile
End With
FSO.MoveFile MyNewFile, TargetFolder
MyFile = Dir
Loop
End Sub
What is possibly going wrong here?
Add a period . in front of Cells(.Rows.Count, "B")... and Cells(.Rows.Count, "A")....
As is, ActiveSheet is implied - you're not actually using the With...End With block.
See Using With Statements for more detail.
I think you just need to do add a "." in front of Cells in the "With" statement:
With ThisWorkbook.Worksheets("Logs")
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = output_file
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = MyFile
End With

Read only one record from Multiple text files into Excel using VBA

I have multiple txt files in a folder, which are tab delimited. Each of these files have a column called EngagementId, which is the same value, irrespective of number of records. However, it changes for every txt file, which is what I want to capture.
I am trying to get the file name in the first row. The GetFileNames() works for that (as pointed out in the comments)
Sub GetFileNames()
Dim sPath As String
Dim sFile As String
Dim iRow As Integer
Dim iCol As Integer
Dim splitFile As Variant
'specify directory to use - must end in "\"
sPath = ActiveWorkbook.Path
iRow = 0
sFile = Dir(sPath & "\Individual Reports\")
Do While sFile <> ""
iRow = iRow + 1
splitFile = Split(sFile, ".txt")
For iCol = 0 To UBound(splitFile)
Sheet1.Cells(iRow, iCol + 1) = splitFile(iCol)
Next iCol
sFile = Dir ' Get next filename
Loop
End Sub
Each of these txt files have one column (which is in the 13th position in each of the text files), called "EngagementId". I want to pull only the first "Engagement Id", which is from the 2nd row(since the first row contains headers).
Sub Extractrec()
Dim filename As String, nextrow As Long, MyFolder As String
Dim MyFile As String, text As String, textline As String
MyFolder = ActiveWorkbook.Path
MyFile = Dir(MyFolder & "\Individual Reports\*.txt")
Do While MyFile <> ""
Open (MyFolder & MyFile) For Input As #1
Do Until EOF(1)
Line Input #1, LineFromFile
LineItems = Split(LineFromFile, "\t") 'second loop text is already stored
'-> see reset text
Sheet1.Cells(iRow, iCol + 2).Value = LineItems(13, 2)
Loop
Close #1
Loop
Using an ADODB.Recordset to query would be more versatile.
Sub Example()
On Error Resume Next
Dim rs As Object, f As Object, conn As Object
Dim FolderPath As String, FileName As String, FilterString As String
FolderPath = "C:\Users\best buy\Downloads\stackoverfow\Sample Data File\"
FileName = "example.csv"
FilterString = "WHERE EngagementId = 20"
Set rs = getDataset(FolderPath, FileName, FilterString)
Do While Not rs.BOF And Not rs.EOF
Debug.Print rs.Fields("EngagementId")
Debug.Print rs.Fields("Company")
Debug.Print rs.Fields("City")
Debug.Print rs.Fields("State")
rs.MoveNext
Loop
Set conn = rs.ActiveConnection
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub
Function getDataset(FolderPath As String, FileName As String, FilterString As String) As Object
Dim conn As Object, rs As Object
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
conn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FolderPath & ";" & _
"Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;""")
rs.ActiveConnection = conn
rs.Source = "SELECT * FROM " & FileName & " " & FilterString
rs.Open
Set getDataset = rs
End Function
Since you only need the second line of each file, you don't need to loop, just read and discard the fist line, then read and split the second one:
Open (MyFolder & MyFile) For Input As #1 'MyFolder & MyFile won't be the correct name (probably should be MyFolder & "\Individual Reports\" & MyFile)
Line Input #1, LineFromFile 'line to discard
Line Input #1, LineFromFile 'line to use
LineItems = Split(LineFromFile, vbTab)
Sheet1.Cells(someplace).Value = LineItems(13) ' replace some place with the correct value that we don't know
Close #1

Automatically Generate CSVs based on cell data

I have the following code which generates a csv file.
Sub WriteCSVFile()
Dim My_filenumber As Integer
Dim logSTR As String
My_filenumber = FreeFile
logSTR = logSTR & Cells(1, "A").Value & " , "
logSTR = logSTR & Cells(2, "A").Value & " , "
logSTR = logSTR & Cells(3, "A").Value & " , "
logSTR = logSTR & Cells(4, "A").Value
Open "D:\BIG DATA\VBA\Sample.csv" For Append As #My_filenumber
Print #My_filenumber, logSTR
Close #My_filenumber
End Sub
This just pulls the top 4 values from the sheets and puts them in a CSV, I now need to modify it to do 2 things, one generate multiple CSVs one for each unique value in column A and then pull values from column B based on column A.
For example:-
Column A contains set A, set B, set C - Set A has 3 tables in column B and I want this to be copied across to the new CSV but I want this to happen for all the sets automatically.
Any help would be greatly appreciated, even a point to another answer?
I am assuming that you want to Print the contents of each Table to the associated Set.
Sub WriteCSVFile2()
Const RootPath As String = "C:\Data Files\Sample_"
Const KillOldFiles As Boolean = True
Dim My_filenumber As Integer
Dim FileName As String
Dim rw As Range
Dim tbls As Collection
Dim tbl As ListObject
Set tbls = getAllTables
My_filenumber = FreeFile
If KillOldFiles Then
For Each rw In Sheet1.ListObjects("SourceTable").DataBodyRange.Rows
FileName = RootPath & rw.Cells(1, 1) & ".csv"
If Len(Dir(FileName)) Then Kill FileName
Next
End If
For Each rw In Sheet1.ListObjects("SourceTable").DataBodyRange.Rows
FileName = RootPath & rw.Cells(1, 1) & ".csv"
Debug.Print FileName
On Error Resume Next
Set tbl = tbls.Item(rw.Cells(1, 2))
If Not tbl Is Nothing Then
Open FileName For Append As #My_filenumber
Print #My_filenumber, getDataBodyRangeCSV(tbl)
Close #My_filenumber
End If
Set tbl = Nothing
On Error GoTo 0
Next
End Sub
Function getDataBodyRangeCSV(tbl As ListObject) As String
Dim c As Range, rw As Range
Dim tr As String, result As String
For Each rw In tbl.DataBodyRange.Rows
For Each c In rw.Cells
tr = tr & c.value & ","
Next
result = result & Left(tr, Len(tr) - 1) & vbCrLf
tr = ""
Next
getDataBodyRangeCSV = Left(result, Len(result) - 1)
End Function
Function getAllTables() As Collection
Dim lists As Collection
Dim tbl As ListObject
Dim ws As Worksheet
Set lists = New Collection
For Each ws In ThisWorkbook.Worksheets
For Each tbl In ws.ListObjects
On Error Resume Next
lists.Add tbl, tbl.Name
On Error GoTo 0
Next
Next
Set getAllTables = lists
End Function
Update: You don't need the more complex example but I am going to leave it. It may be helpful to future viewers.
Cahnge these variables
SouceWorkSheet: The name of the worksheet that your list is on
KillOldFiles: Do you want to delete the old files
arColumns = Array(1, 2, 9, 10): Add the column numbers that you want to export to this array. You just nned to use WriteCSVFile3.
Sub WriteCSVFile3()
Const SouceWorkSheet As String = "Source"
Const RootPath As String = "C:\Data Files\Sample_"
Const KillOldFiles As Boolean = True
Dim My_filenumber As Integer
Dim FileName As String, tr As String
Dim lastRow As Long, x As Long, y
Dim arColumns As Variant
arColumns = Array(1, 2, 9, 10)
My_filenumber = FreeFile
With Worksheets(SouceWorkSheet)
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
If KillOldFiles Then
For x = 2 To lastRow
FileName = RootPath & .Cells(x, 1) & ".csv"
If Len(Dir(FileName)) Then Kill FileName
Next
End If
For x = 2 To lastRow
FileName = RootPath & .Cells(x, 1) & ".csv"
Open FileName For Append As #My_filenumber
For y = 0 To UBound(arColumns)
tr = tr & .Cells(x, arColumns(y)).value & ","
Next
Print #My_filenumber, Left(tr, Len(tr) - 1)
Close #My_filenumber
tr = ""
Next
End With
End Sub
Can't you use something like this ?
Dim OutputFileNum As Integer
OutputFileNum = FreeFile
Open "file.csv" For Output Lock Write As #OutputFileNum
Print #OutputFileNum, "Field1" & "," & "Field2"
SheetValues = Sheets("Sheet1").Range("A1:H9").Value
Dim LineValues() As Variant
ReDim LineValues(1 To 2)
For RowNum = 1 To 9
For ColNum = 1 To 2
LineValues(ColNum) = SheetValues(RowNum, ColNum)
Next
Line = Join(LineValues, ",")
Print #OutputFileNum, Line
Next
Close OutputFileNum

How to use arrays to access files in folder in vba?

had some troubles with this code. It actually is intended to allocate values to the dir1array(ctr1) and dir2array(ctr2) by looping thru all the files in the directory/folder; Is there a way to make this array work ?
Option Explicit
'*********************************************************************
'* Verify if files have the same name before proceeding to compare *
'* their length *
'* DYNAMIC ARRAYs *
'*********************************************************************
Sub findMatchFilenames()
'Dim fso As fileSystemObject
Dim objMapinfo
Dim fso As New Scripting.FileSystemObject
Dim dir1 As Folder
Dim dir2 As Folder
Dim file1 As File
Dim file2 As File
Dim dir1array() As String
Dim dir2array() As String
ReDim dir1array(0 To 100) As String
ReDim dir2array(0 To 100) As String
Dim ctr1 As Integer
Dim ctr2 As Integer
Dim lLen1 As Long, lLen2 As Long
Dim myFile As String, text As String, textline As String
Set fso = New FileSystemObject
Set dir1 = fso.GetFolder("c:\Temp\")
Set dir2 = fso.GetFolder("c:\Tempo\")
ctr1 = 0
For Each file1 In dir1.Files
ctr2 = 0
For Each file2 In dir2.Files
dir1array(ctr1) = file1.Name
dir2array(ctr2) = file2.Name
If dir1array(ctr1) = dir2array(ctr2) Then
MsgBox "" & dir1array(ctr1) & "" & dir2array(ctr2)
Debug.Print file1.Name & " matches " & file2.Name
lLen1 = FileLen(file1)
lLen2 = FileLen(file2)
If lLen1 <> lLen2 Then
Exit Sub
Else
MsgBox "The files have the same length"
End If
End If
ctr2 = ctr2 + 1
Next file2
ctr1 = ctr1 + 1
Next file1
Close #1
End Sub
The following is a variation of your code, but does not use arrays.
Option Explicit
Sub findMatchFilenames()
Dim lLen1 As Long
Dim lLen2 As Long
Dim oFSO As New Scripting.FileSystemObject
Dim dir1 As Folder
Dim dir2 As Folder
Dim oFile1 As File
Dim oFile2 As File
Dim strFolder1 As String
Dim strFolder2 As String
Close #1 ' I always close first when testing (in case I don't get to normal close)
Close #2
Open "C:\Temp\" & Format(Now(), "_SAME_yyyy-mm-dd_hh-mm") & ".txt" For Output As #1
Open "C:\Temp\" & Format(Now(), "_Different_yyyy-mm-dd_hh-mm") & ".txt" For Output As #2
Set oFSO = New FileSystemObject
strFolder1 = "c:\Temp\"
strFolder2 = "c:\Tempo\"
Set dir1 = oFSO.GetFolder(strFolder1)
Set dir2 = oFSO.GetFolder(strFolder2)
For Each oFile1 In dir1.Files
If oFSO.FileExists(strFolder2 & oFile1.Name) Then ' If it matches same name
Set oFile2 = oFSO.GetFile(strFolder2 & oFile1.Name)
If oFile1.Size = oFile2.Size Then
Print #1, oFile1.Name & vbTab & "File found in both folders; Size is the same;"
Debug.Print oFile1.Name & vbTab & "File found in both folders; Size is the same;"
Else
Print #1, oFile1.Name & vbTab & "Found in both folders; Size is DIFFERENT; " & oFile1.Size & " vs: " & oFile2.Size
Debug.Print oFile1.Name & vbTab & "Found in both folders; Size is DIFFERENT; " & oFile1.Size & " vs: " & oFile2.Size
End If
Else ' Same file not found.
Debug.Print "File not present in 2nd folder: " & oFile1.Name
Print #1, oFile1.Name & vbTab & "File NOT found in second folder;"
End If
Next oFile1
Set oFile1 = Nothing
Set oFile2 = Nothing
Set oFSO = Nothing
Close #1
Close #2
End Sub