Extract named cell ranges from Excel workbook based on input parameters and save to CSV file

excelCellRangesToCSV.txt

Sub transpose_cells()

    ' Define the workbook
    Dim wb As Workbook
    Set wb = ThisWorkbook

    ' Define the source worksheet
    Dim ws_source As Worksheet
    Set ws_source = wb.Sheets("Source") ' Replace "Source" with your source sheet name
    
    ' Create the new sheet object
    Dim ws_dest As Worksheet

    ' Delete the sheet if it exists
    On Error Resume Next
    Set ws_dest = wb.Sheets("TransposedData")
    If Not ws_dest Is Nothing Then
        Application.DisplayAlerts = False
        ws_dest.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0

    ' Now add the new sheet for the transposed data
    Set ws_dest = wb.Sheets.Add(After:=ws_source)
    ws_dest.Name = "TransposedData"  ' Give it a name

    ' Turn off screen updating and automatic calculations
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Define the last row in the source sheet
    Dim lastRow As Long
    lastRow = ws_source.Cells(ws_source.Rows.Count, "A").End(xlUp).Row

    ' Define the source and destination ranges
    Dim sourceRange As Range
    Dim destRange As Range

    ' Place the ID and name in the destination sheet for the month
    ws_dest.Cells(1, 1).Value = "month"  ' ID
    ws_dest.Cells(2, 1).Value = "Month"  ' Name

        ' Define the start date and the number of cells
    Dim startDate As Date
    startDate = ws_source.Cells(1, 2).Value ' Start date in cell B1
    Dim numCells As Long
    numCells = ws_source.Cells(2, 2).Value ' Number of cells to take as the range from cell B2
    
    Dim j As Long
    For j = 1 To numCells
        ws_dest.Cells(j + 2, 1).Value = DateAdd("m", j - 1, startDate)
    Next j

    ' Loop over each row in the source table
    Dim i As Long
    For i = 4 To lastRow  ' Start from row 3 since row 2 is taken by months
    
        ' Get the name of the named range from the ID column
        Dim namedRange As String
        namedRange = ws_source.Cells(i, 1).Value  ' Assuming the named range is in the 1st column
    
        ' Get the corresponding Range object
        On Error Resume Next ' Ignore error if the name does not exist
        Set sourceRange = wb.Names(namedRange).RefersToRange
        On Error GoTo 0
        
        ' If the named range does not exist, skip this iteration
        If sourceRange Is Nothing Then
            MsgBox "Named range not found: " & namedRange
            GoTo NextIteration
        End If
    
        ' Place the ID and TITLE in the destination sheet
        ws_dest.Cells(1, i - 2).Value = ws_source.Cells(i, 1).Value  ' ID
        ws_dest.Cells(2, i - 2).Value = ws_source.Cells(i, 2).Value  ' TITLE
    
        ' Set the destination range
        Set destRange = ws_dest.Cells(3, i - 2)
    
        ' Loop through each cell in the destination range and set it to the cell reference in the source sheet
        Dim k As Long
        For k = 0 To numCells - 1  ' One less than numCells
            destRange.Offset(k, 0).Value = sourceRange.Offset(0, k).Value
        Next k
    
NextIteration:
    Next i

    
    SaveToCSV ws_dest ' Call the function passing ws_dest as parameter
    
    ' Delete the TransposedData sheet after saving
    If Not ws_dest Is Nothing And ws_dest.Name = "TransposedData" Then
        wb.Sheets(1).Activate
        Application.DisplayAlerts = False
        ws_dest.Delete
        Application.DisplayAlerts = True
    End If

    ' Turn back on the screen updating and automatic calculations
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Sub SaveToCSV(ws As Worksheet)

    ' Define workbook
    Dim wb As Workbook
    Set wb = ThisWorkbook

    ' Prompt for File Suffix
    Dim FileSuffix As String
    FileSuffix = InputBox("Enter File Suffix")

    ' Define filename
    Dim filename As String
    filename = wb.Path & "\" & Replace(Left(wb.Name, Len(wb.Name) - Len(Split(wb.Name, ".")(UBound(Split(wb.Name, ".")))) - 1), FileSuffix, "") & "_" & FileSuffix & ".csv"

    ' Save the worksheet as CSV in the same directory as the workbook
    ws.Copy
    ActiveWorkbook.SaveAs filename, xlCSV
    ActiveWorkbook.Close False

    ' Alert the user
    MsgBox "File has been saved as " & filename

End Sub