excelvbacsvexport-to-csv

Export sheet in a workbook to CSV file in the same location every week


I have a sheet in a workbook I would like to export to a csv file that gets updated every week. So ideally, I want the VBA code to export whatever data is in the sheet and overwrite what was existing in the path. The range of data is from A to AJ. The path of the folder will be on "C:\Users\HS"

I tried to adapt @VBasic2008 code at the location below to no avail.

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

The result displays/flashes on the screen when I run it but doesn't get saved at the location specified.

Here is exactly what I had:

Option Explicit

Sub ExportColumnsToCSV()
    
    Const sfRow As Long = 1
    Const sColsList As String = "A:AJ"
    
    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 & "C:\Users\HS"
    
    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

Thank you HS


Solution

  • Here is an update with all previously mentioned comments and your recent request

    Option Explicit
    
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
        If TodayIsTheDay Then
            ExportColumnsToCSV
        End If
    
    End Sub
    
    Private Property Get TodayIsTheDay() As Boolean
    
        ' = 5 would be Friday
        ' = 6 would be Saturday
        ' = 1 would be Monday so on and so forth
        If Weekday(Date, vbMonday) = 5 Then TodayIsTheDay = True
    
    End Property
    
    Private Sub ExportColumnsToCSV()
    
        Dim wsTheWorksheetYouWant As Worksheet
    
        ' This is where you are going to change the worksheet name to the name you need
        
        Set wsTheWorksheetYouWant = Application.Worksheets("yourWorksheetName")
    
        Dim lBottomRow As Long
    
        On Error Resume Next
            lBottomRow = wsTheWorksheetYouWant.Range("$A:$A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        On Error GoTo 0
    
        If lBottomRow <= 1 Then
            ' This assumes there is no data but still has coulmn headers.
    
            MsgBox "there is only 1 row of data here"
        Else
            Dim rngTheRangeYouWant as range
            Set rngTheRangeYouWant = wsTheWorksheetYouWant.Range("$A$1:$AJ$" & lBottomRow)
    
            With rngTheRangeYouWant
            
                Dim oNewWorkbook As Workbook
                Set oNewWorkbook = Application.Workbooks.Add
                
                rngTheRangeYouWant.Copy
                With oNewWorkbook
                    .Worksheets(1).Range("A1").PasteSpecial xlPasteValues
                    
                    Application.DisplayAlerts = False
                    
                    ' If you want to make the name dynamic to the date then do it like this
                    Dim DatedFileName As String                     ' I Broke it up this way so you can make the filename dynamic as well
                    DatedFileName = Format(Date, "yyyymmdd") & "_" & "SomeGenericName" & ".csv"
                    
                    'Change this to your path with extension like
                    .SaveAs Filename:="C:\Users\yourpath\" & DatedFileName, FileFormat:=xlCSVUTF8, Local:=False
                    
                    .Close
                        
                    Application.DisplayAlerts = True
                End With
            
            End With
    
        End If
    
        Set rngTheRangeYouWant = Nothing
        Set oNewWorkbook = Nothing
    
    End Sub