I have a table (Table8) that I need to export as .txt file.
The code I'm currently using works fine but also exports empty rows from the table which messes up the .txt file for further use.
The table will have information in 1 to n rows (usually not more than 100).
I would like to only export those rows, which have text in them (other rows have a formula in them and currently appear as blank in .txt file).
Code I'm currently using:
Sub saveToMtext()
Dim filename As String, lineText As String
Dim myrng As Range, i, j
filename = ThisWorkbook.path & "\textfile-" & Format(Now, "ddmmyy-hhmmss") & ".txt"
ChDir (ThisWorkbook.path)
Open "m_text.txt" For Output As #1
FileFormat = xlText & CreateBackup = False
Set myrng = Range("Table8")
For i = 1 To myrng.Rows.Count
For j = 1 To myrng.Columns.Count
lineText = IIf(j = 1, "", lineText & vbTab) & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
End Sub
I changed from regular IF to IF x Then Exit For and got it working.
Final code:
Sub saveToMtext()
Dim filename As String, lineText As String
Dim myrng As Range, i, j
Dim LValue As String
filename = ThisWorkbook.path & "\textfile-" & Format(Now, "ddmmyy-hhmmss") & ".txt"
ChDir (ThisWorkbook.path)
Open "m_text.txt" For Output As #1
FileFormat = xlText & CreateBackup = False
Set myrng = Range("Table8")
k = 11
For i = 1 To myrng.Rows.Count
LValue = Cells(k, 121)
m = Len(LValue)
If m < 1 Then Exit For
For j = 1 To myrng.Columns.Count
lineText = IIf(j = 1, "", lineText & vbTab) & myrng.Cells(i, j)
Next j
Print #1, lineText
k = k + 1
Next i
Close #1
End Sub
Related
I am a real novice at VBA, so any help would be welcome. I am trying to convert certain ranges across multiple sheets into only one file. I have written code for a similar situation that produces a TXT file for each sheet, however now I need the same sheets/same ranges into only one TXT file. My original setup would produce about 30 files from 30 sheets, so now I would need all 30 sheets in a specific range in one file. Here is my original code:
Dim linetext As String
Dim myrange As Range
Dim FileName As String
' Next Sheet tab for conversion
FileName = ThisWorkbook.Path & "\" & "50002 LIGHTING" & ".txt"
Open FileName For Output As #1
Set myrange = Sheet1.Range("J11:L161")
For i = 1 To 150
For j = 1 To 3
linetext = IIf(j = 1, "", linetext & vbTab) & myrange.Cells(i, j)
Next j
Print #1, linetext
Next i
Close #1
FileName = ThisWorkbook.Path & "\" & Sheet5.Range("D7") & " " & Sheet5.Range("C6") & ".txt"
Open FileName For Output As #5
Set myrange = Sheet5.Range("J11:L161")
For i = 1 To 150
For j = 1 To 3
linetext = IIf(j = 1, "", linetext & vbTab) & myrange.Cells(i, j)
Next j
Print #5, linetext
Next i
Close #5
' Next Sheet tab for conversion
MsgBox (All Files Transformed from Excel to .TXT")
End Sub
Export Ranges
Option Explicit
Sub ExportRanges()
Const ExportFileName As String = "Test.txt"
Const ExportRangeAddress As String = "J11:L161"
Dim WorksheetObjects As Variant
WorksheetObjects = VBA.Array(Sheet1, Sheet5)
Dim FilePath As String: FilePath = ThisWorkbook.Path & "\" & ExportFileName
Dim FileNum As Long: FileNum = FreeFile
Open FilePath For Output As FileNum
Dim Data As Variant
Dim n As Long, rCount As Long, cCount As Long, r As Long, c As Long
Dim LineText As String
For n = 0 To UBound(WorksheetObjects)
Data = WorksheetObjects(n).Range(ExportRangeAddress).Value
If n = 0 Then
rCount = UBound(Data, 1)
cCount = UBound(Data, 2)
End If
For r = 1 To rCount
For c = 1 To cCount
LineText = IIf(c = 1, "", LineText & vbTab) & Data(r, c)
Next c
Print #FileNum, LineText
Next r
Next n
Close FileNum
MsgBox "Ranges exported to text file.", vbInformation
End Sub
I need help with code, I want my macro to open a .txt file and write only 1-9 rows(copy from Excel) in one txt file and then open next .txt file and write 9-18 and so on until data in the excel rows is finished under each column.
Below code only paste 1-9 rows from Excel to Txt file and stop.
So it means if I have 36 rows in Excel(A1-A36) it should create 3 txt files each with 9 rows only.
Sub env_gen()
Dim filename As String
Dim linetext As String
Dim my_range As Range
filename = ThisWorkbook.Path & "\Monday123" & ".txt"
Open filename For Output As #1
Set my_range = Worksheets("sheet1").Range("A1:A9")
For i = 1 To 9
For j = 1 To 1
linetext = IIf(j = 1, "", linetext & ",")
Next j
Print #1, linetext
Next i
Close #1
MsgBox ("File is created")
End Sub
To iterate over a range, you can use a loop and put the index inside the range address. Eg. For i = 1 to 9: Cells(i, 1) = .... This loop can also use the ranges size as a parameter to ensure you loop over the whole range and only the range (no extra). Eg. For i = 1 To my_range.Rows.Count.
When looping within a loop, you can also use the outer loops index as a parameter for the inner loop. Eg. For i = 1 to 36 Step 9: For j = i to i + 8
Here is an example of those techniques implemented with your code:
Sub env_gen()
Dim filename As String
Dim linetext As String
Dim CurrentStep As Long
Dim my_range As Range
Set my_range = Worksheets("sheet1").Range("A1:A36")
For i = 1 To my_range.Rows.Count Step 9
CurrentStep = CurrentStep + 1
filename = ThisWorkbook.Path & "\Monday123 (" & CurrentStep & ").txt"
Open filename For Output As #1
For j = i To i + 8
linetext = my_range.Cells(i).Text & IIf(j <> i + 8, "", ",")
Print #1, linetext
Next j
Close #1
Next i
MsgBox ("Files are created")
End Sub
Sub ExportDataTSV()
Dim BCS As Worksheet
Dim Ctrl As Worksheet
Dim ws As Worksheet
Dim FName As String
Dim insertValues As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set BCS = ThisWorkbook.Sheets(Sheet2.Name)
Set Ctrl = ThisWorkbook.Sheets(Sheet1.Name)
fileDate = Year(Now) & "_" & Month(Now) & "_" & Day(Now) & "_" & Format(Now, "hh")
#If Mac Then
NameFolder = "documents folder"
If Int(Val(Application.Version)) > 14 Then
'You run Mac Excel 2016
folder = _
MacScript("return POSIX path of (path to " & NameFolder & ") as string")
'Replace line needed for the special folders Home and documents
folder = _
Replace(SpecialFolder, "/Library/Containers/com.microsoft.Excel/Data", "")
Else
'You run Mac Excel 2011
folder = MacScript("return (path to " & NameFolder & ") as string")
End If
FName = folder & ":bcs_output.txt"
#Else
folder = Environ$("userprofile")
FName = folder & "\Documents\bcs_output_" & fileDate & ".txt"
#End If
If Ctrl.Range("D9") = "" Or Ctrl.Range("D10") = "" Then
MsgBox "Please enter the Scenario Year and Scenario you wish to save and click again", vbOKOnly
Exit Sub
End If
Ctrl.Range("D9").Copy
BCS.Range("AS2").PasteSpecial Paste:=xlPasteValues
Ctrl.Range("D10").Copy
BCS.Range("AT2").PasteSpecial Paste:=xlPasteValues
Call ClearFile(FName)
With BCS
.AutoFilter.ShowAllData
numrows = .Cells(.Rows.Count, 1).End(xlUp).Row
numcol = .Cells(2, Columns.Count).End(xlToLeft).Column
.Range("AS1").Value = "scenario_year"
.Range("AS2:AS" & numrows).FillDown
.Range("AT1").Value = "scenario"
.Range("AT2:AT" & numrows).FillDown
.Range("AU1").Value = "save_date"
.Range("AU2").Formula = "=NOW()"
.Range("AU2:AU" & numrows).FillDown
.Range("AU2:AU" & numrows).NumberFormat = "yyyy-mm-dd hh:mm"
For x = 2 To numrows
Set rng1 = .Range("A" & x & ":R" & x)
Set rng2 = .Range("AC" & x & ":AF" & x)
Set rng3 = .Range("AH" & x & ":AK" & x)
Set rng4 = .Range("AN" & x & ":AO" & x)
Set rng5 = .Range("AS" & x & ":AU" & x)
Set Data = Union(rng1, rng2, rng3, rng4, rng5)
insertValues = Join2D(ToArray(Data), Chr(9))
Call ConvertText(FName, insertValues)
Next x
End With
With BCS
.Activate
.Range("A1").Select
End With
Ctrl.Activate
Application.ScreenUpdating = True
MsgBox "Cluster Data saved to " & FName & ", please upload the file here: https://awsfinbi.corp.amazon.com/s/dcgs_abv/submit", vbOKOnly
Application.EnableEvents = True
End Sub
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1
Next c
Next col
Next ar
ToArray = arr
End Function
Public Function Join2D(ByVal vArray As Variant, Optional ByVal sWordDelim As String = " ", Optional ByVal sLineDelim As String = vbNewLine) As String
Dim i As Long, j As Long
Dim aReturn() As String
Dim aLine() As String
ReDim aReturn(LBound(vArray, 1) To UBound(vArray, 1))
ReDim aLine(LBound(vArray, 2) To UBound(vArray, 2))
For i = LBound(vArray, 1) To UBound(vArray, 1)
For j = LBound(vArray, 2) To UBound(vArray, 2)
'Put the current line into a 1d array
aLine(j) = vArray(i, j)
Next j
'Join the current line into a 1d array
aReturn(i) = Join(aLine, sWordDelim)
Next i
Join2D = Join(aReturn, sLineDelim)
End Function
Public Function ClearFile(myfile)
Open myfile For Output As #1: Close #1
End Function
Public Function ConvertText(myfile As String, strTxt As String)
Open myfile For Append As #1
Write #1, strTxt
Close #1
End Function
The above functions are what I have strung together from various SO post and googles. It works to a large degree, but when it creates the txt file with the tab delimiter it gives an output where in the text separator is a single quote. However, the entire line is wrapped in double quotes. So the output looks something like "'Field1'\t'Field2'\t'Field3'" . That is not a valid TSV format for loading into a database like Redshift due to the double quotes. I need the double quotes to not be in the file, can anyone identify why it is adding them? Is there a way to prevent it or a better way to create a tab delimited file output for loading to Redshift?
For further information it MUST be a txt with tab delimiter, I have no control over that requirement.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/writestatement
Unlike the Print # statement, the Write # statement inserts commas
between items and quotation marks around strings as they are written
to the file. You don't have to put explicit delimiters in the list.
Write # inserts a newline character, that is, a carriage
return-linefeed (Chr(13) + Chr(10) ), after it has written the final
character in outputlist to the file.
To not add quotes switch to Print:
Print #1, strTxt
I am able to print the values from excel to notepad, but the format is bit different,
Dim txtFile As String, rng As Range, cellValue As Variant, r As Integer, c As Integer
txtFile = slocation & "\" & "Cont_name_" & Filename & ".txt"
lrow = Range("I" & Rows.Count).End(xlUp).Row
Range("A2:G" & lrow).Select
Set rng = Selection
Open txtFile For Output As #1
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
cellValue = rng.Cells(r, c).Value
If InStr(cellValue, "/") Then
cellValue = Format(cellValue, "yyyyMMDD")
End If
If c = rng.Columns.Count Then
Print #1, cellValue
Else
Print #1, cellValue,
End If
Next c
Next r
Close #1
Spaces are more than the requirement, please help to achieve the desired output,because the tool is accepting only the desired format
Your first output uses the standard "print zones" in every 14th column (positions 1, 15, 29, ...), which you get by printing with appended comma
.............|.............|.............|.............|.............|.............|
XXX-XX-XXXX 20190111 AA 123 NAME NAME XXXXX
Your desired output starts at the next multiple of 8 characters (1, 9, 17, ...)
.......|.......|.......|.......|.......|.......|.......|.......|.......|
XXX-XX-XXXX.....20190111........AA......123.....NAME....NAME....XXXXX
You can set the next print position in your file by Seek
Private Sub SaveAsText()
Dim rng As Range
Dim r As Long, c As Long
Set rng = ActiveSheet.Range("A1:G1")
Dim file1 As Integer
file1 = FreeFile
Open ThisWorkbook.Path & "\test.txt" For Output As file1
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If c = 1 Then
Print #file1, CStr(rng.Cells(r, c).Value);
Else
Seek #file1, (Seek(file1) \ 8 + 1) * 8 + 1
Print #file1, CStr(rng.Cells(r, c).Value);
End If
Next c
Next r
Close #file1
End Sub
Additional Hints:
Use Freefile to get the next free file number (which might be 1).
Use CStr() to prevent the automatically added space characters before and after numeric values.
I want to import multiple csv files at the bottom of an existing table. However, when importing the files, it always excludes the first row of the list of each file. The first row of the list differs from the first row of the spreadsheet because in between there are other rows that are not needed (e.g. titles, empty rows...). Resuming: if I upload 5 files, it miss the first desired row of each of the 5 files.
This is the code:
Private Sub Import_auction_offers_Click()
Dim strSourcePath As String
Dim strFile As String
Dim Cnt As Long
'Change the path to the source folder accordingly
strSourcePath = "C:\Users\L18944\Desktop\example"
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
Cnt = Cnt + 1
Open strSourcePath & strFile For Input As #1
If Range("F2").Value <> "" Then
Range("F1").End(xlDown).offset(1, 0).Select
Else:
Range("F1:F" & Range("F" & Rows.Count).End(xlUp).Row).offset(1, 0).Select
End If
currentRow = 0
rowNumber = 0
'EOF(1) checks for the end of a file
Do Until EOF(1)
Line Input #1, lineFromFile
fileStr = Split(lineFromFile, vbLf)
Dim item As Variant
For Each item In fileStr
'For item = LBound(fileStr) To UBound(fileStr)
lineitems = Split(item, ";")
'Debug.Print (item)
If rowNumber = 1 Then
startDate = lineitems(6)
End If
If rowNumber > 3 And item <> "" Then
If Not doesOfferExist(CStr(lineitems(2))) Then
ActiveCell.offset(currentRow, 0) = startDate
ActiveCell.offset(currentRow, 1) = lineitems(4)
ActiveCell.offset(currentRow, 2) = lineitems(3)
ActiveCell.offset(currentRow, 3) = CDbl(lineitems(6))
ActiveCell.offset(currentRow, 4) = CDbl(lineitems(7))
ActiveCell.offset(currentRow, 5) = lineitems(8)
ActiveCell.offset(currentRow, 6) = lineitems(1)
ActiveCell.offset(currentRow, 7) = lineitems(2)
ActiveCell.offset(currentRow, 8) = "New"
currentRow = currentRow + 1
End If
End If
rowNumber = rowNumber + 1
Next item
Loop
Close #1
Name strSourcePath & strFile As strSourcePath & strFile
strFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then _
MsgBox "No CSV files were found...", vbExclamation
End Sub
Does anyone understand why it miss the first line of each imported list?
Thank you in advance
I didn't go through your ImportAuctionOffers code, but I'm assuming you are finding the new starting row for each file.
This code will let you pick your files (and set your initial directory). Then loop through all the selected items, calling your ImportAuctionOffers procedure for each file.
Sub test()
Dim oFileDialog As FileDialog
Set oFileDialog = Application.FileDialog(msoFileDialogFilePicker)
oFileDialog.AllowMultiSelect = True
oFileDialog.InitialFileName = "C:\Temp" ' can set your default directory here
oFileDialog.Show
Dim iCount As Integer
For iCount = 1 To oFileDialog.SelectedItems.Count
Call ImportAuctionOffers(oFileDialog.SelectedItems(iCount))
Next
End Sub
Update:
For your second issue: Not reading the first data line is likely due to the if statements with RowNumber.
rowNumber=0
Do ...
if RowNumber = 1 Then ...
if RowNumber > 3 ...
RowNumber = RowNumber + 1
loop
Your code is not going to enter either of your if statements when RowNumber equals 0, 2, or 3. You probably just need to change your > 3 to either > 2, or >= 3.