EXCEL-VBA How to export to a CSV... a custom range of columns?

Question

I have the following VBA macro that I get from the web, a long time ago... and it´s working OK in Excel:

Sub ExportCSV()

Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook

Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy

Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
End With

MyFileName = CurrentWB.Path & "\FOLDER\" & Left(CurrentWB.Name, InStrRev(CurrentWB.Name, ".") - 1) & ".csv"
'Optionally, comment previous line and uncomment next one to save as the current sheet name
'MyFileName = CurrentWB.Path & "\" & CurrentWB.ActiveSheet.Name & ".csv"


Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSVUTF8, CreateBackup:=False, Local:=False
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub

I just need to edit/modify it to get only columns in the range "A:AV", to reduce the CSV file size... and simply, don´t know how to do it!

Can anyone help me?

Assuming that your data starts at cell A1, try adjusting the range being copied to Range("A1:AV" & Cells(Rows.Count, "A").End(xlUp).Row).Copy. — user6585761
– user6585761, Commented Jun 27, 2021 at 1:05
@Domenic Thank you for your kindly help! I have just overwritten the line: With TempWB.Sheets(1).Range("A1") and replace it by: With TempWB.Sheets(1).Range("A1:AV" & Cells(Rows.Count, "A").End(xlUp).Row).Copy but it seems it´s not the way to do it... I get an error message "424" that says an object is required =( It seems I'n not applying your suggestion in the right way... any idea? — Speedbit
– Speedbit, Commented Jun 27, 2021 at 1:15
Simply replace ActiveWorkbook.ActiveSheet.UsedRange.Copy with Range("A1:AV" & Cells(Rows.Count, "A").End(xlUp).Row).Copy. — user6585761
– user6585761, Commented Jun 27, 2021 at 1:52
My apologies, I see that I worded my original response poorly. — user6585761
– user6585761, Commented Jun 27, 2021 at 1:54
@Domenic You're the man! jejeje Yes! Now it does exactly what it's supposed to do.- Anyway I'm facing other problem... and it´s that the CSV file it´s still not lighten enough =( Could you help me for example to only get a range of columns in the CSV... like "A:F", "H:I", "V", and "AM:AV"? — Speedbit
– Speedbit, Commented Jun 27, 2021 at 2:43

VBasic2008 · Accepted Answer · 2021-06-27 08:44:25Z

1

Export Columns to CSV

Adjust the values in the constants section.
If your list separator is a semicolon, you may want to use Local:=True.

Option Explicit

Sub ExportColumnsToCSV()
    
    Const sfRow As Long = 1
    Const sColsList As String = "A:F,H:I,V,AM:AV"
    
    Const dFirst As String = "A1"
    
    
    Dim sCols() As String: sCols = Split(sColsList, ",")
    
    Dim sws As Worksheet: Set sws = ActiveSheet
    Dim swb As Workbook: Set swb = sws.Parent
    
    Dim srrg As Range
    Dim slCell As Range
    Dim srCount As Long
    
    With sws.Rows(sfRow)
        Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If slCell Is Nothing Then
            MsgBox "No data in worksheet.", vbCritical, "Export to CSV"
            Exit Sub
        End If
        srCount = slCell.Row - .Row + 1
        Set srrg = .Resize(srCount)
    End With
    
    Dim srg As Range
    Dim n As Long
    
    For n = 0 To UBound(sCols)
        If srg Is Nothing Then
            Set srg = Intersect(srrg, sws.Columns(sCols(n)))
        Else
            Set srg = Union(srg, Intersect(srrg, sws.Columns(sCols(n))))
        End If
    Next n
    
    Dim dwb As Workbook: Set dwb = Application.Workbooks.Add
    srg.Copy
    dwb.Worksheets(1).Range(dFirst).PasteSpecial xlPasteValues
    
    Dim dFolderPath As String: dFolderPath = swb.Path & "\Folder\"
    
    On Error Resume Next
    MkDir dFolderPath
    On Error GoTo 0
    
    Dim dFilePath As String
    dFilePath = dFolderPath _
        & Left(swb.Name, InStrRev(swb.Name, ".") - 1) & ".csv"
    ' Optionally, out-comment previous line and uncomment next one
    ' to save with the current worksheet name.
    'dFilePath = dFolderPath & sws.Name & ".csv"

    Application.DisplayAlerts = False
    dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSVUTF8, Local:=False
    dwb.Close SaveChanges:=False
    Application.DisplayAlerts = True

End Sub

answered Jun 27, 2021 at 8:44

VBasic2008

56.9k5 gold badges21 silver badges38 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Speedbit Over a year ago

Thank you very much!! It does EXACTLY what I want! I'm happy like a child with a new toy! hehehe - Brilliant solution.

FaneDuru Over a year ago

Nice... Voted it up. I think, just for the sake of playing with arrays, I am able to adapt it a little, to avoid using clipboard, using only arrays. I will try doing in the next minutes. I have a function I used for such array discontinuous columns slicing, but I must adapt it for the case of column ranges containing adiacent columns expressed by ":" (something like A:F, in the above code).

VBasic2008 Over a year ago

Thx, the idea came to mind, but I was extremely short on time. I'm looking forward to seeing your improvement (BTW, I hate the two lines starting with srg.Copy, too. I prefer drg.Value = dData.).

FaneDuru · Accepted Answer · 2021-06-28 11:26:31Z

Just for the sake of using arrays, next code will not use the clipboard. It is fast even for big ranges to be processed:

Sub ExportColumnsToCSV_Array()
    Const sfRow As Long = 1
    Const sColsList As String = "A:F,H:I,V,AM:AV"
    Const dFirst As String = "A1"
    
    Dim sCols() As String: sCols = Split(sColsList, ",")
    Dim sws As Worksheet: Set sws = ActiveSheet
    Dim swb As Workbook: Set swb = sws.Parent
    
    Dim srrg As Range
    Dim slCell As Range, arrCol, arr, lastRow As Long, lastCol As Long
    
    If sws.UsedRange.cells.count <= 1 Then Exit Sub 'to avoid the next checking of lastRow and lastCol
    With sws.rows(sfRow)
        lastRow = .Resize(.Worksheet.rows.count - sfRow + 1) _
                   .Find("*", , xlFormulas, , xlByRows, xlPrevious).row 'last row of the range to be copied
    End With
    lastCol = ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Column 'and its last column
    
    arr = sws.Range("A1").Resize(lastRow, lastCol).value               'places the range to be copied in an array
    'obtain array of necessary columns numbers:
    arrCol = buildColAr(sColsList)
    Debug.Print Join(arrCol, ","):  'just to see what array has been returned...
    
    'Extract from the initial array only the necessary columns:
    arr = Application.Index(arr, Application.Evaluate("row(1:" & lastRow & ")"), arrCol)
    
    Dim dwb As Workbook: Set dwb = Application.Workbooks.Add
    'drop the processed array result, at once:
    dwb.Worksheets(1).Range(dFirst).Resize(UBound(arr), UBound(arr, 2)).value = arr
    
    Dim dFolderPath As String: dFolderPath = swb.Path & "\Folder\"
    
    If Dir(dFolderPath, vbDirectory) = "" Then MkDir dFolderPath
    Dim dFilePath As String
    dFilePath = dFolderPath & left(swb.Name, InStrRev(swb.Name, ".") - 1) & ".csv"
        
    Application.DisplayAlerts = False
     dwb.saveas FileName:=dFilePath, FileFormat:=xlCSVUTF8, Local:=False
     dwb.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

Private Function buildColAr(ByVal v As Variant) As Variant 
 Dim i&, temp, cols As Long, arrFilt, El, j As Long, k As Long
 
 v = Split(v, ","): arrFilt = Filter(v, ":", True)   'in arrFilt will be kept the continuous ranges (like A:F)
 For Each El In arrFilt
        cols = cols + Range(El).Columns.count 'calculate the total number of columns to ReDim the array able to keep them
 Next
 ReDim temp(LBound(v) To UBound(v) - UBound(arrFilt) + cols - 1) 'Redim the necessary array to keep the columns number
 For i = LBound(v) To UBound(v)
    If InStr(v(i), ":") > 0 Then   'the case of adiacent columns ranges
        For j = 1 To Range(v(i)).Columns.count
            temp(k) = Range(v(i)).Columns(j).Column: k = k + 1
        Next j
    Else
        temp(k) = cells(1, v(i)).Column: k = k + 1
    End If
 Next i
 buildColAr = temp
End Function

Collectives™ on Stack Overflow

EXCEL-VBA How to export to a CSV... a custom range of columns?

2 Answers 2

Export Columns to CSV

3 Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Export Columns to CSV

3 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related