How to create a new seperate formatted csv using VBA from an existing sheet-CodePudding

Currently I have the following data and VBA code, where the VBA searches for the starting row which contains the current day 1, it selects this as the start of the range and also selects the next 11 rows of data as a range and exports this data as a new csv as depicted below: Current Code:

Sub CreateCV2()

Dim r As Variant
' Find the date in column A
r = Application.Match(CLng(Date   1), Range("A:A"), 0)

' Only proceed if date has been found
If Not IsError(r) Then
   Dim wb As Workbook
   Set wb = Workbooks.Add()
 
   ThisWorkbook.Worksheets("Sheet1").Cells(r, 1).Resize(11, 3).Copy _
       Destination:=wb.Worksheets(1).Range("A1:A1")

   wb.SaveAs _
       Filename:="C:\Users\Lach\Desktop\DATA2\operational" & ".csv", _
       FileFormat:=xlCSV, _
       CreateBackup:=False
End If

End Sub

My question is, how do I modify my VBA so that instead of the result depicted in b) from the picture above, I can get the data in the following format depicted in c) below. Where the data ignores the “Day” column and doesn’t copy it across, and so it also renames and includes the column headers “GasDate” and “Gas Value GJ” as depicted in the picture below.

CodePudding user response：

(not tested, assuming everything else works following should work)

Replace

ThisWorkbook.Worksheets("Sheet1").Cells(r, 1).Resize(11, 3).Copy _
Destination:=wb.Worksheets(1).Range("A1:A1")

with

With ThisWorkbook.Worksheets("Sheet1").Cells(r, 1).Resize(11, 1)
    Union(.offset(0,0), .offset(0,2)).Copy _ 
    Destination:=wb.Worksheets(1).Range("A2:A2")
End with
wb.Worksheets(1).Range("A1").value="GasDate"
wb.Worksheets(1).Range("B1").value="Gas Value GJ"

CodePudding user response：

Export Data to CSV

Option Explicit

Sub ExportGas()
    
    Const sName As String = "Sheet1"
    Const sColsList As String = "A,C"
    Const sirCount As Long = 11
    
    Const dHeadersList As String = "GasDate,Gas Value GJ"
    Const dColsList As String = "A,B"
    Const dfRow As Long = 1
    Const dFilePath As String = "C:\Users\Lach\Desktop\DATA2\gas.csv"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlCSV ' xlCSVUTF8 '
    
    Const DaysAfter As Long = 1
    
    Dim sCols() As String: sCols = Split(sColsList, ",")
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    
    Dim fDate As Date: fDate = Date   DaysAfter
    Dim sfRow As Variant
    sfRow = Application.Match(CLng(fDate), sws.Columns(sCols(0)), 0)
    If IsError(sfRow) Then Exit Sub ' date not found
    
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCols(0)).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow   1
    If srCount > sirCount Then srCount = sirCount
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCols(0)).Resize(srCount)
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet) ' single ws
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
    
    Dim dHeaders() As String: dHeaders = Split(dHeadersList, ",")
    Dim dCols() As String: dCols = Split(dColsList, ",")
    
    Dim c As Long
    
    For c = 0 To UBound(sCols)
        dws.Cells(1, dCols(c)) = dHeaders(c) ' write header
        dws.Cells(2, dCols(c)).Resize(srCount).Value _
            = srg.EntireRow.Columns(sCols(c)).Value ' write data
    Next c
    
    Application.DisplayAlerts = False ' overwrite without confirmation
    dwb.SaveAs dFilePath, dFileFormat
    Application.DisplayAlerts = True
    dwb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    MsgBox "Gas exported.", vbInformation

End Sub