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)
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 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
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
This is what I got:
For j = 4 & 8 To LastCol
What I need is the expression for: Variable j schould be the whole column 4 and 8 to the last column.
How to write that.
Here is my complete code:
Sub Neu()
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Dim i As Long
Dim j As Long
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
CellData = ""
FilePath = ThisWorkbook.Path & "\Excel Data (Print).txt"
Open FilePath For Output As #2
For i = 1 To LastRow
For j = 4 & 8 To LastCol
If j = LastCol Then
CellData = CellData + Trim(ActiveCell(i, j).Value)
Else
CellData = CellData + Trim(ActiveCell(i, j).Value) + " "
End If
Next j
Print #2, CellData
CellData = ""
Next i
If j = LastCol Then
CellData = CellData + Trim(ActiveCell(i, j).Value)
Else
CellData = CellData + Trim(ActiveCell(i, j).Value) + " "
End If
Print #2, CellData
CellData = ""
Close #2
MsgBox ("Textfile erzeugt und im selben Ordner wie Excel-Original abgelegt. Name: Excel Data (Print).txt")
End Sub
To do the same thing in every column, just remove the "& 8"
For j = 4 To LastCol
Can someone assist with how I can use this function below that converts my data in an excel file to an XML file in a sub? When I go to create a macro it by default has it for sub but I need to have it as a function. I need to be able to use this as maybe a custom button on the toolbar possibly or how can I use it for any spreadsheet I need to convert it from Excel to an XML file?
Public Function ExportToXML(FullPath As String, RowName _
As String) As Boolean
On Error GoTo ErrorHandler
Dim colIndex As Integer
Dim rwIndex As Integer
Dim asCols() As String
Dim oWorkSheet As Worksheet
Dim sName As String
Dim lCols As Long, lRows As Long
Dim iFileNum As Integer
Set oWorkSheet = ThisWorkbook.Worksheets(1)
sName = oWorkSheet.Name
lCols = oWorkSheet.Columns.Count
lRows = oWorkSheet.Rows.Count
ReDim asCols(lCols) As String
iFileNum = FreeFile
Open FullPath For Output As #iFileNum
For i = 0 To lCols - 1
'Assumes no blank column names
If Trim(Cells(1, i + 1).Value) = "" Then Exit For
asCols(i) = Cells(1, i + 1).Value
Next i
If i = 0 Then GoTo ErrorHandler
lCols = i
Print #iFileNum, "<?xml version=""1.0""?>"
Print #iFileNum, "<" & sName & ">"
For i = 2 To lRows
If Trim(Cells(i, 1).Value) = "" Then Exit For
Print #iFileNum, "<" & RowName & ">"
For j = 1 To lCols
If Trim(Cells(i, j).Value) <> "" Then
Print #iFileNum, " <" & asCols(j - 1) & "><![CDATA[";
Print #iFileNum, Trim(Cells(i, j).Value);
Print #iFileNum, "]]></" & asCols(j - 1) & ">"
DoEvents 'OPTIONAL
End If
Next j
Print #iFileNum, " </" & RowName & ">"
Next i
Print #iFileNum, "</" & sName & ">"
ExportToXML = True
ErrorHandler:
If iFileNum > 0 Then Close #iFileNum
Exit Function
End Function
To convert to a Sub that could be run from a button you would change it to:
Public Sub ExportToXML()
This will automatically change the last line to End Sub.
FullPath and RowName will no longer be passed as function-arguments, so would, presumably, need to be read from cells on a worksheet, or perhaps from two InputBoxes.
The Sub would no longer return a Boolean value, so whatever happens with this value would have to be converted to code within the same Sub (or possibly passed to another Sub).