Transfer Data to the Worksheet

Option Explicit

Sub TestArraysToSheet()
    'test proc for transfers to the sheet
    'de-comment lines to test the code
    
    Dim vDim1 As Variant, vDim2 As Variant, vTemp As Variant, vR
    Dim oSht As Worksheet, r As Long, c As Long, rTarget As Range
    Dim Rng as range
    
    ' set choice of worksheet
    Set oSht = ActiveWorkbook.Worksheets("Sheet2")
    set rng=osht.cells(1,1)
    
    ' clear existing contents of worksheet
    oSht.Activate
    oSht.Cells.ClearContents
    
    ' load 1D test array
    vDim1 = Array(9, 8, 7, 5, 6, 4, 3, 2, 1, 0) 'or,
    'vDim1 = Array("Horses", "Dogs", "Zebras", "Fleas") 'or,
    'vDim1 = Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", " ") 'zero based
    
    ' load 2D test array
    ReDim vDim2(1 To 20, 1 To 10)
    For r = 1 To 20
      For c = 1 To 10
         vDim2(r, c) = (r * c)
      Next c
    Next r
    
    ' CLEARING THE SHEET
    '-------------------
    oSht.Cells.ClearContents   ' clears sheet text entries only
    'oSht.Cells.ClearFormats    ' clears sheet formats only
    'oSht.Cells.Clear           ' clears everthing on sheet
    'oSht.Range("A1:G37").ClearContents   'clears entries from cell block
    'oSht.Range(oSht.Cells(1, 1), oSht.Cells(1, 9)).ClearContents 'clears entries from cell block
    'ClearRange rng, "contents"                                   'clears cell range according to option 
    'ClearWorksheet("Sheet2", 1 )                                 'clears all sheet2 cell contents only       
    
    ' REMOVE ALL WORKBOOK CHARTS
    '---------------------------
    'DeleteAllWorkbookCharts    'clears all charts from the workbook - not just those on top sheet
    
   '' TRANSFER SINGLE VALUES TO SHEET
    '--------------------------------
    'oSht.Cells(3, 7).Value = "Totals"         'string to one specified cell
    'oSht.Range("A1").Value = "Totals"         'string to one specified cell
    
    
    ' TRANSFER ONE VALUE TO A SHEET BLOCK
    '------------------------------------
    'oSht.Range(oSht.Cells(1, 1), oSht.Cells(10, 7)).Value = "N/A"
    'oSht.Range("A1:F10").Value = "N/A"
    
    
    'TRANSFER 1 DIMENSION LIST ARRAYS TO WORKSHEET
    '---------------------------------------------
    Array1DToSheetRow vDim1, "Sheet2", 3, 7    ' 1D array to sheet row, start position (3,7)
    
    'Array1DToSheetCol vDim1, "Sheet2", 3, 7    ' 1D array to sheet column, start position (3,7)
            
    
    'TRANSFER 2 DIMENSIONAL ARRAYS TO WORKSHEET
    '------------------------------------------
    'Array2DToSheet vDim2, "Sheet2", 2, 2       ' 2D array to sheet, start position (2,2)
    
    'Arr1Dor2DtoWorksheet vDim2,"Sheet2",4,5     ' 1D or 2D array to worksheet; 2D here. 
    
    'TransArray2DToSheet vDim2, "Sheet2", 2, 2  ' TRANSPOSED 2D array to sheet, start position (2,2)
    
    'TransposeArray2D vDim2, vTemp              ' alternative method of TRANSPOSED 2D array to sheet
    'Array2DToSheet vTemp,"Sheet2" , 1, 1

    'FORMAT WORKSHEET CELLS AFTER TRANSFER
    '------------------------------------------
    'FormatCells "Sheet2"                      'applies one of several formats to all cells of the worksheet  
    'FormatRange Rng, "bold"                   'applies one of several formats to the specified cell range
    
End Sub

Sub Array1DToSheetCol(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of single dimension list array to specified position in worksheet
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nElem As Long
    Dim nNewC As Long, nNewR As Long
    
    ' get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    ' get the pre-shift end points
    nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
           
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow + nElem - 1, nStartCol))
    
    'transfer the array contents to the sheet range
    rTarget.Value = Application.WorksheetFunction.Transpose(vIn)

End Sub

Sub Array1DToSheetRow(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of single dimension list array into a worksheet column
    ' The cell for the first element is set by nStartRow and nStartCol
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nElem As Long
    Dim nNewC As Long, nNewR As Long
    
    ' get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    ' get the pre-shift end points
    nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
           
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow, nStartCol + nElem - 1))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Sub TransArray2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions TRANSPOSED
    ' The cell for the first element is set by nStartRow and nStartCol
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'swap cols and rows
    nNewEndR = nCols + nStartRow - 1
    nNewEndC = nRows + nStartCol - 1
       
    ' define the transposed range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = Application.WorksheetFunction.Transpose(vIn)

End Sub

Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'modify end point for parameter starting values
    nNewEndR = nRows + nStartRow - 1
    nNewEndC = nCols + nStartCol - 1
       
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
                         ByVal nRow As Long, ByVal nCol As Long) As Boolean
    
    'Transfers a one or two dimensioned input array vA to the worksheet,
    'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
    'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
            
    Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
    Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
    Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
    
    'CHECK THE INPUT ARRAY
    On Error Resume Next
        'is it an array
        If IsArray(vA) = False Then
            bProb = True
        End If
        'check if allocated
        nR = UBound(vA, 1)
        If Err.Number <> 0 Then
            bProb = True
        End If
    Err.Clear
        
    If bProb = False Then
        'count dimensions
        On Error Resume Next
        Do
            nD = nD + 1
            nR = UBound(vA, nD)
        Loop Until Err.Number <> 0
    Else
        MsgBox "Parameter is not an array" & _
        vbCrLf & "or is unallocated - closing."
        Exit Function
    End If
    'get number of dimensions
    Err.Clear
    nDim = nD - 1: 'MsgBox nDim

    'get ref to worksheet
    Set oSht = ThisWorkbook.Worksheets(sSht)
       
    'set a worksheet range for array
    Select Case nDim
    Case 1 'one dimensional array
        LBR = LBound(vA): UBR = UBound(vA)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
    Case 2 'two dimensional array
        LBR = LBound(vA, 1): UBR = UBound(vA, 1)
        LBC = LBound(vA, 2): UBC = UBound(vA, 2)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
    Case Else 'unable to print more dimensions
        MsgBox "Too many dimensions - closing"
        Exit Function
    End Select

    'transfer array values to worksheet
        rng.Value = vA
    
    'release object variables
    Set oSht = Nothing
    Set rng = Nothing
    
    'returns
    Arr1Dor2DtoWorksheet = True

End Function

Function TransposeArray2D(vA As Variant, Optional vR As Variant) As Boolean
        
    '---------------------------------------------------------------------------------
    ' Procedure : Transpose2DArr
    ' Purpose   : Transposes a 2D array; rows become columns, columns become rows
    '             Specifically, (r,c) is moved to (c,r) in every case.
    '             Options include, returned in-place with the source changed, or
    '             if vR is supplied, returned in that instead, with the source intact.
    '---------------------------------------------------------------------------------
    
    Dim vW As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vR)
    If Not bWasMissing Then Set vR = Nothing
    
    'use a work array
    vW = vA
    
    'find bounds of vW data input work array
    loR = LBound(vW, 1): hiR = UBound(vW, 1)
    loC = LBound(vW, 2): hiC = UBound(vW, 2)
    
    'set vR dimensions transposed
    'Erase vR 'there must be an array in the variant to erase
    ReDim vR(loC To hiC, loR To hiR)
    
    'transfer data
    For r = loR To hiR
        For c = loC To hiC
            'transpose vW into vR
            vR(c, r) = vW(r, c)
        Next c
    Next r
    
    'find bounds of vW data input work array
'    loR = LBound(vR, 1): hiR = UBound(vR, 2)
'    loC = LBound(vR, 2): hiC = UBound(vR, 2)


TRANSFERS:
    'decide whether to return in vA or vR
    If Not bWasMissing Then
        'vR was the intended return array
        'so leave vR as it is
    Else:
        'vR is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'return success for function
    TransposeArray2D = True
    
End Function

Sub testCellRefConversion()
    'run this to cell reference conversions
     
    Dim nNum As Long, sLet As String
    
    'set input values here
    nNum = 839
    sLet = "AFG"
    
    MsgBox ConvColAlphaToNum(sLet)

    MsgBox ConvColNumToAlpha(nNum)

End Sub

Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
    'Converts an Excel column reference from alpha to numeric
    'For example, "A" to 1, "AFG" to 839 etc

    Dim nColNum As Long
    
    'get the column number
    nColNum = Range(sColAlpha & 1).Column
   
    'output to function
    ConvColAlphaToNum = nColNum
    
End Function

Function ConvColNumToAlpha(ByVal nColNum As Long) As String
    'Converts an Excel column reference from numeric to alpha
    'For example, 1 to "A", 839 to "AFG" etc

    Dim sColAlpha As String, vA As Variant
    
    'get the column alpha, in form $D$14
    sColAlpha = Cells(1, nColNum).Address
    
    'split the alpha reference on $
    vA = Split(sColAlpha, "$")
      
    'output second element (1) of array to function
    ConvColNumToAlpha = vA(1) 'array is zero based
  
End Function

Sub DeleteAllWorkbookCharts()
    'run this manually to delete all charts
    'not at this stage called in any procedure
        
    Dim oC
    
    Application.DisplayAlerts = False
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    Application.DisplayAlerts = True
    
End Sub

Sub FormatCells(sSht As String)
    ' Applies certain formats to all cells
    ' of the named parameter sheet
    
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets(sSht)
    oSht.Activate
    
    'format all cells of the worksheet
    oSht.Cells.Select
    With Selection
        .Font.Name = "Consolas"
        .Font.Size = 20
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    oSht.Range("A1").Select

End Sub

Sub testFormatRange()
    'place some text in cell 1,1 of sheet1
    
    Dim oSht As Worksheet, Rng As Range

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    Set Rng = oSht.Cells(1, 1)
    
    FormatRange Rng, "autocols"
    Rng.Select
    
    Set Rng = Nothing

End Sub

Sub FormatRange(ByRef rRange As Range, ByVal sOpt As String)
    ' Applies certain formats to
    ' the parameter range of cells
    ' in accordance with selected option
    
    With rRange
        Select Case LCase(sOpt)
            Case "consolas"                     'make monospaced
                .Font.Name = "Consolas"
            Case "calibri"                      'make non-mono
                .Font.Name = "Calibri"
            Case "autocols"                     'autofit column width
                .Columns.AutoFit
            Case "noautocols"                   'default column width
                .ColumnWidth = 8.43
            Case "hcenter"                      'center text horizontally
                .HorizontalAlignment = xlCenter
            Case "hleft"                        'left text horizontally
                .HorizontalAlignment = xlLeft
            Case "bold"                         'bold text
                .Font.Bold = True
            Case "nobold"                       'normal weight text
                .Font.Bold = False
            Case "italic"                       'italic text
                .Font.Italic = True
            Case "noitalic"                     'non-italic text
                .Font.Italic = False
            Case "underline"                    'underlined text
                .Font.Underline = xlUnderlineStyleSingle
            Case "nounderline"                  'non-underlined text
                .Font.Underline = xlUnderlineStyleNone
            Case Else
        End Select
    End With

End Sub

Sub testClearWorksheet()
    'run this to test worksheet clearing
    
    If SheetExists("Sheet1") Then
        ClearWorksheet "Sheet11", 3
    Else 'do other stuff
    End If

End Sub

Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
   'clears worksheet contents, formats, or both
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
      
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Function
    End Select
   End With
   oWSht.Cells(1, 1).Select
   
   ClearWorksheet = True

End Function

Sub testClearRange()
    'place some text in cell 1,1 of sheet1
    
    Dim oSht As Worksheet, Rng As Range

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    Set Rng = oSht.Cells(1, 1)
    
    ClearRange Rng, "all"
    Rng.Select
    
    Set Rng = Nothing

End Sub

Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
   'clears cell range contents, formats, or both
   'sOpt options: "contents", "formats", or "all"
   'sOpt is optional, default "contents".
   
   With rRng
    Select Case LCase(sOpt)
        Case "contents"  'contents only
            .ClearContents
        Case "formats"   'formats only
            .ClearFormats
        Case "all"       'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearRange - closing"
        Exit Sub
    End Select
   End With
      
End Sub