Got any Excel/VBA Questions? Free Excel Help
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
See also:
| Automatically Add Date, Time or Date & Time |
| Display Excel AutoFilter Criteria |
| Use AutoFilter in Excel VBA to Filter by Date & Time |
Free Training Course: Lesson 1 - Excel Fundamentals
See also: Index to Excel VBA Code; Index to Excel Freebies; Lesson 1 - Excel Fundamentals; Index to how to… providing a range of solutions
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.