VBA to export selected row values of excel to csv-CodePudding

I have a requirement for VBA, wherein, If I select a cell in excel, it will export that entire row values to csv.

I have tried

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 "C:\Users\xxxxx\Desktop\Sample.csv" For Append As #My_filenumber
    Print #My_filenumber, logSTR
Close #My_filenumber

End Sub

If the range selection can be made dynamic, it can solve the purpose.

CodePudding user response：

Export Selection Rows to CSV

Sub ExportRowsToCSV()

    Const FILE_PATH_RIGHT As String = "\Desktop\Sample.csv"
    Const FIRST_CELL_ADDRESS As String = "A2"
    Const ColDelimiter As String = "," ' or ";"
    Const RowDelimiter As String = vbLf
    
    If ActiveSheet Is Nothing Then Exit Sub ' no visible workbook open
    If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
    If Not TypeOf Selection Is Range Then Exit Sub ' not a range selected
    
    Dim FilePath As String
    FilePath = Environ("USERPROFILE") & FILE_PATH_RIGHT
    ' or:
    'FilePath = Environ("OneDrive") & FILE_PATH_RIGHT
    
    Dim drg As Range: Set drg = Selection
    Dim ws As Worksheet: Set ws = drg.Worksheet
    
    Dim srg As Range
    With ws.UsedRange
        Dim lCell As Range: Set lCell = .Cells(.Rows.Count, .Columns.Count)
        Set srg = ws.Range(FIRST_CELL_ADDRESS, lCell)
    End With
    
    Dim rg As Range: Set rg = Intersect(srg, drg)
    If rg Is Nothing Then Exit Sub
    Set rg = Intersect(srg, rg.EntireRow)
    If rg Is Nothing Then Exit Sub
    
    Dim dLen As Long: dLen = Len(ColDelimiter)
    
    Dim rString As String
    
    Dim rrg As Range
    Dim cell As Range
    
    For Each rrg In rg.Rows
        For Each cell In rrg.Cells
            rString = rString & CStr(cell.Value) & ColDelimiter
        Next cell
        rString = Left(rString, Len(rString) - dLen) & RowDelimiter
    Next rrg
    rString = Left(rString, Len(rString) - Len(RowDelimiter))
    
    Dim TextFile As Long: TextFile = FreeFile
    
    Open FilePath For Append As #TextFile
        Print #TextFile, rString
    Close #TextFile

    MsgBox "Row(s) exported.", vbInformation

End Sub

CodePudding user response：

Here I got the code to copy the "values in the entire row where the cell is active" and paste to csv file.

'''

Sub xlRangeToCSVFile() 
Dim myWB As Workbook 
Dim rngToSave As Range 
Dim fNum As Integer 
Dim csvVal As String 
Dim i As Integer 
Set myWB = ThisWorkbook
csvVal = ""
fNum = FreeFile
Set rngToSave = Range("A" & ActiveCell.Row & ":J" & ActiveCell.Row)
Open "C:\Users\xxxxx\Desktop\Sample.csv" For Output As #fNum
i = 1
For j = 1 To rngToSave.Columns.Count
csvVal = csvVal & Chr(34) & rngToSave(i, j).Value & Chr(34) & ","
Next
Print #fNum, Left(csvVal, Len(csvVal) - 1)
csvVal = ""
Close #fnum
End Sub

'''