excelvbarowuser-input

Adding Rows and Columns Based on User Input

I'm trying to create a table based upon user inputs: number of Areas, number of Floors, and number of Buildings.

Example output:
enter image description here

I figured out how to use VBA to copy/paste X Amount of columns (buildings) based on user input.
I figured out how to filldown in VBA for the areas.

I can't add floors automatically.
I can't tie it all together in the table.

Example code for the columns being added:

Private Sub cmd_Button_Columns_Click()
'  Add Buildings

Dim N As Integer
N = Range("A2").Value

Select Case N

Case 1
' Copy_Sheet = "Employing VBA Macros"
Copy_Cell = "f1:i7"
' Paste_Sheet = "Employing VBA Macros"
Paste_Cell = "k1:n7"
' Worksheets(Copy_Sheet).Range(Copy_Cell).Copy
Me.Range(Copy_Cell).Copy
' Worksheets(Paste_Sheet).Range(Paste_Cell).PasteSpecial
Me.Range(Paste_Cell).PasteSpecial Paste:=xlPasteAll

Case 2
Copy_Cell = "f1:i7"
Paste_Cell = "k1:n7"
Me.Range(Copy_Cell).Copy
Me.Range(Paste_Cell).PasteSpecial Paste:=xlPasteAll
Paste_Cell = "p1:s7"
Me.Range(Paste_Cell).PasteSpecial Paste:=xlPasteAll

Case 3
Copy_Cell = "f1:i7"
Paste_Cell = "k1:n7"
Me.Range(Copy_Cell).Copy
Me.Range(Paste_Cell).PasteSpecial Paste:=xlPasteAll
Paste_Cell = "p1:s7"
Me.Range(Paste_Cell).PasteSpecial Paste:=xlPasteAll
Paste_Cell = "u1:x7"
Me.Range(Paste_Cell).PasteSpecial Paste:=xlPasteAll

Case 0
Range("k1:z7").ClearContents

End Select

End Sub

Example code for the rows:

Sub Add_Areas()
' Add Areas

Dim Resizer As Integer
Dim a As Variant
a = InputBox("Please enter the MAX number of Areas for your project", "NUMBER OF AREAS") 'First we ask for user input

On Error GoTo notvalid  'We add an error handler, so if the user would enter text like "seven", the sub will exit with a message
Resizer = CInt(a)       'we store the input in a variable which has to be an integer, if the user enters text it will couse an error so we jump to the end
If Resizer < 2 Then GoTo notvalid 'We also check if the number is higher than 1, othervise it couses error, or copies the 19th row to the 20th
On Error GoTo 0 'We reset the error handling so we can see if something else goes wrong.

ThisWorkbook.Sheets("Sheet1").Visible = True
ThisWorkbook.Sheets("Sheet1").Select
ThisWorkbook.Sheets("Sheet1").Rows(20 + 1).EntireRow.Insert shift:=xlDown 'add a new row under the 20th row/above the 21st row
ThisWorkbook.Sheets("Sheet1").Rows(20).Resize(Resizer).FillDown
Exit Sub    'We exit the sub before the error message.

notvalid: 'in case of error we jump here
    MsgBox "Please enter a number which is 2 or higher"
End Sub
Solution

  • Microsoft documentation:

    Range.Offset property (Excel)

    Range.Resize property (Excel)

    Range.HorizontalAlignment property (Excel)

    Option Explicit
Sub Demo()
    Dim iBldg As Long, iFloor As Long, iArea As Long
    Dim arrRes, iR As Long, i As Long, j As Long
    Dim rCell As Range
    Const START_CELL = "C1"
    iBldg = Range("B1")
    iFloor = Range("B2")
    iArea = Range("B3")
    ReDim arrRes(iFloor * iArea + 1, 2)
    arrRes(1, 0) = "Floor"
    arrRes(1, 1) = "Area"
    iR = 1
    For i = 1 To iFloor
        For j = 1 To iArea
            iR = iR + 1
            If j = 1 Then arrRes(iR, 0) = i
            arrRes(iR, 1) = j
        Next
    Next
    Set rCell = Range(START_CELL)
    For i = 1 To iBldg
        With rCell
            .Resize(UBound(arrRes) + 1, 3).Value = arrRes
            .Value = "Building " & i
            .Resize(, 3).Merge
            .MergeArea.EntireColumn.HorizontalAlignment = xlCenter
            Set rCell = .Offset(, 1)
        End With
    Next
End Sub

    enter image description here