Use Array Elements To Fill a Range With Headings

NEW! More Books..

Add Excel Answers & Search To Your Google Toolbar Details

Current Special! Complete Excel Excel Training Course for Excel 97 - Excel 2003, only ~~$145.00~~. $59.95 Instant Buy/Download, 30 Day Money Back Guarantee & Free Excel Help for LIFE!

Back to: Excel VBA . Got any Excel/VBA Questions? Free Excel Help

Use Array Elements To Fill a Range, Chosen By User, With Headings

Sub ArrayToTable()
    Dim vArray(), vArrayHeadings()
    Dim rTable As Range
    Dim rCell As Range
    Dim lArrayElmnt As Long
    Dim lHeads As Long, lRows As Long
    Dim lreply As Long, lDataCells As Long
     
     'Fill   arrays
    vArray = Array(1, 2, 3, 4, 5, 6, 7)
    vArrayHeadings = Array("Head1", "Head2", "Head3", "Head4")
     
    On Error Resume Next
    Set rTable = Cells(1, 1)
    Set rTable = Application.InputBox(Prompt:="Select Table Range", Type:=8)
    If rTable Is Nothing Or rTable.Address = "$A$1" Then Exit Sub 'cancel or non valid range
     
    lHeads = UBound(vArrayHeadings) + 1
    lDataCells = UBound(vArray)
    lRows = lDataCells / lHeads
     
    If lHeads <> rTable.Columns.Count Then
        lreply = MsgBox("Selection Range Must Have " & _
        lHeads & " Columns. Try Again", vbQuestion + vbCritical + vbOKCancel)
         
        If lreply = vbCancel Then
            Exit Sub
        Else
            Run "ArrayToTable"
        End If
    ElseIf rTable.Rows.Count <> lRows + 1 Then
        lreply = MsgBox("Table Range (Including  Headings) Must Be " & _
        lHeads & " Columns Wide By " & lRows + 1 & " Rows High." _
        & " Try Again", vbQuestion + vbOKCancel)
         
        If lreply = vbCancel Then
            Exit Sub
        Else
            Run "ArrayToTable"
        End If
    End If
     
     
    With rTable
            With .Range(Cells(1, 1), Cells(1, UBound(vArrayHeadings) + 1))
                 .Value = vArrayHeadings
                 .Font.Bold = True
            End With
        Set rTable = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
    End With
     
    For Each rCell In rTable
        rCell = vArray(lArrayElmnt)
        lArrayElmnt = lArrayElmnt + 1
        If lArrayElmnt = lDataCells Then Exit Sub
    Next rCell
     
    On Error GoTo 0
End Sub

Excel Dashboard Reports & Excel Dashboard Charts 50% Off

Special! Free Choice of Complete Excel Training Course OR Excel Add-ins Collection on all purchases totaling over $64.00. ALL purchases totaling over $150.00 gets you BOTH! Purchases MUST be made via this site. Send payment proof to special@ozgrid.com 31 days after purchase date.

Instant Download and Money Back Guarantee on Most Software

Excel Trader Package Technical Analysis in Excel With $139.00 of FREE software!

Microsoft Ž and Microsoft Excel Ž are registered trademarks of Microsoft Corporation. OzGrid is in no way associated with Microsoft