CODEWITHSUNDEEP
vbaexcel
PeterS
PeterS

Reputation: 724

How To Create Text File From Excel Values

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: enter image description here

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.

enter image description here

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:

enter image description here

How can I achieve my expected output mentioned above?

Upvotes: 1

Views: 3861

Answers (2)

Biju John
Biju John

Reputation: 1

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)

Upvotes: 0

ManishChristian
ManishChristian

Reputation: 3784

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

Upvotes: 2

Related Questions