i need help plz
I have a excel file and I want to export all data from it to a text file.
This the source code:
Sub ExceltoText()
Dim FileName, sLine, Deliminator, x, y, z As String
Dim LastCol, LastRow, FileNumber As Integer
FileName = "C:\Users\Administrateur\Desktop\App vba\ExcToTxt.txt"
Deliminator = "|"
x = "$|0|Les Données de SALARIES"
y = "=|0|Les Données de SALARIES"
z = "=|1|SALARIES|"
LastCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
FileNumber = FreeFile
Open FileName For Output As FileNumber
For i = 1 To LastRow
For j = 1 To LastCol
If j = LastCol Then
sLine = z & sLine & Cells(i, j).Value
Else
sLine = sLine & Cells(i, j).Value & Deliminator
End If
Next j
If i = 1 Then i = 2
Print #FileNumber, sLine
sLine = ""
Next i
Close #FileNumber
MsgBox "File generated"
End Sub
In the result I got this text file in that format:
=|1|SALARIES|PSA_etablissement|PSA_SALARIE|
=|1|SALARIES|001|10635|
=|1|SALARIES|001|10637|
But I want my text file to be like that:
$=|1|SALARIES|PSA_etablissement|PSA_SALARIE|
=|1|SALARIES|001|10635|
=|1|SALARIES|001|10637|
and I want to add those lines in the beginning of the text file:
$|0|Les Données de SALARIES
=|0|Les Données de SALARIES
Try this routine:
Added the two lines outside your for loop.
Also '&' and '=' is the only difference in that line, so take it as a variable without those symbols.
Sub ExceltoText()
Dim FileName As String, sLine As String, Deliminator As String
Dim x As String, y As String, z As String
Dim LastCol As Integer, LastRow As Integer, FileNumber As Integer
FileName = "C:\Users\Administrateur\Desktop\App vba\ExcToTxt.txt"
Deliminator = "|"
x = "$=|1|SALARIES|PSA_etablissement|PSA_SALARIE|"
y = "|0|Les Données de SALARIES"
z = "=|1|SALARIES|"
LastCol = ActiveSheet.Cells.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = ActiveSheet.Cells.Cells(Rows.Count, 1).End(xlUp).Row
FileNumber = FreeFile
Open FileName For Output As FileNumber
Print #FileNumber, "$" & y
Print #FileNumber, "=" & y
Print #FileNumber, x
For i = 1 To LastRow
For j = 1 To LastCol
If j = LastCol Then
sLine = z & sLine & Cells(i, j).Value
Else
sLine = sLine & Cells(i, j).Value & Deliminator
End If
Next j
Print #FileNumber, sLine
sLine = ""
Next i
Close #FileNumber
MsgBox "File generated"
End Sub
To add the lines at the beginning of the file, just before the FOR loop add:
Print #FileNumber, x
Print #FileNumber, y
To put that dollar sign before only the first line while iterating change:
If i = 1 Then i = 2
Print #FileNumber, sLine
sLine = ""
To:
If i = 1 Then
i = 2
Print #FileNumber, "$" & sLine
Else
Print #FileNumber, sLine
End If
sLine = ""
Related
I'm trying to create a new .tsv file by running below code. But the output is still in .csv file eventhough i have set it to .tsv. Is there any way to solve this?
Sub toTxt()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
myFile = Application.DefaultFilePath & "\PO" & Format(Now(), "yyyymmddhhmmss") & ".tsv"
iLast = ThisWorkbook.Sheets("PO_Master").Range("C" & Rows.Count).End(xlUp).Row
Set rng = ThisWorkbook.Sheets("PO_Master").Range("A7:BA" & iLast)
Open myFile For Output As #2
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Write #2, cellValue
Else
Write #2, cellValue,
End If
Next j
Next i
Close #2
Sample output
ASA,"AA","BB","CC","DD","EE","FF"
Try building up a string outputline (you'll need to declare that) and only write the data each row.
For i = 1 To rng.Rows.Count
outputline = ""
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If outputline = "" Then
outputline = outputline & cellValue
Else
outputline = outputline & Chr(9) & cellValue
End If
Next j
Print #2, outputline
Next i
I am trying to copy an Excel range to a .txt file.
The export is successful, with one exception, It adds one "extra" empty line at the end.
I've read and tests many of the solution on SO (and other sites), but still without any success.
My Code (relevant part)
' === Export to the .txt file ===
Dim TxtFileName As String, lineText As String
TxtFileName = ThisWorkbook.Path & "\Inv_" & Format(Date, "yyyymmdd") & ".txt"
Open TxtFileName For Output As #1
With StockSht
For i = 1 To LastRow
For j = 1 To 3
If j = 3 Then
lineText = lineText & .Cells(i, j).Value2
Else ' j = 1 or 2
lineText = lineText & .Cells(i, j).Value2 & vbTab
End If
Next j
Print #1, lineText
lineText = ""
Next i
End With
Close #1
My StockSht (worksheet object) and LastRow are defined correctly, and getting their values.
Screen-shot of the end of the exported .txt file
You can use a semi-colon in the Print statement to control the insertion point (i.e. prevent the line-feed on the last line).
The relevant bit on the MSDN page:
Use a semicolon to position the insertion point immediately after the last character displayed.
I tested this code:
Sub PrintTest()
Dim lng As Long
Open "C:\foo3.txt" For Output As #1
For lng = 1 To 10
If lng < 10 Then
Print #1, "foo" & lng
Else
Print #1, "foo" & lng; '<-- semi-colon prevents the newline
End If
Next lng
Close #1
End Sub
So I would update your code like below (not tested):
' === Export to the .txt file ===
Dim TxtFileName As String, lineText As String
TxtFileName = ThisWorkbook.Path & "\Inv_" & Format(Date, "yyyymmdd") & ".txt"
Open TxtFileName For Output As #1
With StockSht
For i = 1 To LastRow
For j = 1 To 3
If j = 3 Then
lineText = lineText & .Cells(i, j).Value2
Else ' j = 1 or 2
lineText = lineText & .Cells(i, j).Value2 & vbTab
End If
Next j
'--- new bit: check for i against LastRow and add the semicolon on last row
If i <> LastRow Then
Print #1, lineText
Else
Print #1, lineText; '<-- semi colon keeps insertion point at end of line
End If
lineText = ""
Next i
End With
Close #1
Try using a ; on the last print line.
' === Export to the .txt file ===
Dim TxtFileName As String, lineText As String
TxtFileName = ThisWorkbook.Path & "\Inv_" & Format(Date, "yyyymmdd") & ".txt"
Open TxtFileName For Output As #1
With StockSht
For i = 1 To LastRow
For j = 1 To 3
If j = 3 Then
lineText = lineText & .Cells(i, j).Value2
Else ' j = 1 or 2
lineText = lineText & .Cells(i, j).Value2 & vbTab
End If
Next j
If i = LastRow Then
Print #1, lineText;
Else
Print #1, lineText
End if
lineText = ""
Next i
End With
Close #1
I want to append a range from "A2:B" & LastRow to a log txt file with a ; delimiter.
For now I know how to read from separate cells but not from "A2:B"
Column A = text
Column B2:B = =IF(A2="","",1)
My code:
Dim strData As String
Dim strLine As String
strData = ""
Open "\\x-ap01\Log.txt" For Input As #1
While EOF(1) = False
Line Input #1, strLine
strData = strData + strLine & vbCrLf
Wend
strData = strData + Cells(2, 1) & ";" & Cells(2, 2) & ";"
Close #1
Open "\\x-ap01\Log.txt" For Output As #1
Print #1, strData
Close #1
Do you mean like this?
Sub x()
Dim strData As String
Dim strLine As String
Dim lastrow As Long
Dim r As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Open "\\x-ap01\Log.txt" For Append As #1
For r = 2 To lastrow
If Cells(r, 1) <> vbNullString Then
strData = strData & Cells(r, 1) & ";" & Cells(r, 2) & ";"
strData = strData & strLine & vbCrLf
End If
Next r
Print #1, strData
Close #1
End Sub
Im currently working on a tool that will enable me to create my specific profile for entries present in my Excel File.
Assuming that I have these values:
Male:
And I want to generate a text file like this one below. There must be separate filename for both female and male and one file per row only.
I currently have this code below:
Sub toFile()
Dim FilePath As String, CellData As String, LastCol As Long, LastRow As Long
Dim Filenum As Integer
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 1 To LastRow
FilePath = Application.DefaultFilePath & "\" & Trim(ActiveSheet.Cells(i, 1).Value) & ".xpd"
Filenum = FreeFile
Open FilePath For Output As Filenum
CellData = ""
For j = 2 To LastCol
CellData = Trim(ActiveSheet.Cells(i, j).Value)
Write #Filenum, CellData
Next j
Close #Filenum
Next i
MsgBox ("Done")
End Sub
Sample Output of this code:
How can I achieve my expected output mentioned above?
Here is the final code which will create two files and won't write values where cells are blank:
Sub toFile()
Dim FilePath As String, CellData As String, LastCol As Long, LastRow As Long
Dim Filenum As Integer
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To LastRow
FilePath = Application.DefaultFilePath & "\" & Trim(ActiveSheet.Cells(i, 1).Value) & ".TXT"
Filenum = FreeFile
Open FilePath For Output As Filenum
CellData = ""
For j = 2 To LastCol
If Trim(ActiveSheet.Cells(i, j).Value) <> "" Then
CellData = Trim(ActiveSheet.Cells(1, j).Value) & ": " & Trim(ActiveSheet.Cells(i, j).Value)
Write #Filenum, CellData
End If
Next j
Close #Filenum
Next i
MsgBox ("Done")
End Sub
Use the below code
Change the code
For i = 2 To LastRow
and
celldata = Trim(ActiveSheet.Cells(1, j)) & ": " & Trim(ActiveSheet.Cells(i, j).Value)
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