Excel VBA - Summary table fori Vacant and Occupied

ivandgreat · May 21st 2015

Dears,

Good day! I would like to make a summary of my table using excel vba.

From attached file, i have a number of rows which specify the name/number of rooms in col B and at col C mentioned number of occupied rooms.

If the value in col C, for example show as "Occupied 2" it will take the first 2 rows and make the summary table which is shown on col E to J. if it is "Occupied 8" it will occupy the 8 rows.. and so on.

if the next rows (after occupying the number of rows mentions) is vacant, it will count the number of vacant until it reach the row with values again.

This will have a loop until the last rows in col B and create the summary table.

Thanks in advance.

br,
Ivan

richadj4 · May 22nd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Does it have to use VBA? This does it with formulasforum.ozgrid.com/index.php?attachment/65301/

ivandgreat · May 22nd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Thank richdj4.

i prefer to use VBA, since i have a 2000 rows to work on, which is on different sheets.

richadj4 · May 22nd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

The table will work for a million or so rows, you just have to set the named ranges Rooms and remarks accordingly. If you'd really prefer VBA, I'll try and knock something up tonight

**KjBox** · May 22nd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Try this

Code

Sub Summary()
    Dim x, y, i As Long, ii As Long, iCount as integer
    
    x = Cells(1).CurrentRegion: i = 2
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Do While i <= UBound(x, 1)
        If x(i, 3) <> vbNullString Then
            ii = i + 1: j = j + 2
            If j = 2 Then j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 5) = Split(x(i, 3))(1)
            y(j, 3) = x(i, 2): y(j, 4) = x(i + y(j, 5) - 1, 2)
            Do Until x(ii, 3) <> vbNullString
                ii = ii + 1: If ii = UBound(x, 1) Then Exit Do
                iCount = iCount + 1
            Loop
            If iCount + 1 <> CInt(y(j, 5)) Then
                If ii = UBound(x, 1) Then Exit Do
                y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii - 1, 2)
                y(j + 1, 6) = ii - i - CInt(y(j, 5))
            Else
                j = j - 1
            End If
            iCount = 0
        End If
        i = ii
    Loop
    With Cells(4, 5).CurrentRegion.Offset(1)
        .ClearContents
        .Borders.LineStyle = xlNone
        .Resize(UBound(y, 1)) = y
    End With
    With Cells(4, 5).CurrentRegion.Resize(j + 1)
        .Borders.Weight = 2
        .Columns(1).HorizontalAlignment = xlCenter
        .Columns(5).HorizontalAlignment = xlCenter
        .Columns(6).HorizontalAlignment = xlCenter
    End With
    
End Sub

Display More

Working file attached, click button to run code and create summary.

ivandgreat · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Thanks KjBox, i just edit the table but it didn't show the right output.

**KjBox** · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

You're welcome

ivandgreat · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Dear KjBox, could you please check it again, i just edit the table, but it didn't show the right output.

Thanks.

**KjBox** · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Hi,

OK it goes wrong if the first group of rooms are all occupied, must have missed that scenario in my testing.

Replace the code with this:

Code

Sub Summary()
    Dim x, y, i As Long, ii As Long, iCount As Integer
    
    x = Cells(1).CurrentRegion: i = 2
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Do While i <= UBound(x, 1)
        If x(i, 3) <> vbNullString Then
            ii = i + 1: j = j + 2
            If i = 2 Then j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 5) = Split(x(i, 3))(1)
            y(j, 3) = x(i, 2): y(j, 4) = x(i + y(j, 5) - 1, 2)
            Do Until x(ii, 3) <> vbNullString
                ii = ii + 1: If ii = UBound(x, 1) Then Exit Do
                iCount = iCount + 1
            Loop
            If iCount + 1 <> CInt(y(j, 5)) Then
                If ii = UBound(x, 1) Then Exit Do
                y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii - 1, 2)
                y(j + 1, 6) = ii - i - CInt(y(j, 5))
            Else
                j = j - 1
            End If
            iCount = 0
        End If
        i = ii
    Loop
    With Cells(4, 5).CurrentRegion.Offset(1)
        .ClearContents
        .Borders.LineStyle = xlNone
        .Resize(UBound(y, 1)) = y
    End With
    With Cells(4, 5).CurrentRegion.Resize(j + 1)
        .Borders.Weight = 2
        .Columns(1).HorizontalAlignment = xlCenter
        .Columns(5).HorizontalAlignment = xlCenter
        .Columns(6).HorizontalAlignment = xlCenter
    End With
    
End Sub

Display More

ivandgreat · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Thanks again, i edit again the table, but it didn't show the right output.

**KjBox** · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

OK, I think (certainly hope!) this should cover all room occupancy/groups scenarios

Code

Sub Summary()
    Dim x, y, i As Long, ii As Long, iCount As Integer
     
    x = Cells(1).CurrentRegion: i = 2
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Do While i <= UBound(x, 1)
        If x(i, 3) <> vbNullString Then
            ii = i + 1: j = j + 2
            If i = 2 Then j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 5) = Split(x(i, 3))(1)
            y(j, 3) = x(i, 2): y(j, 4) = x(i + y(j, 5) - 1, 2)
            Do Until x(ii, 3) <> vbNullString
                ii = ii + 1: If ii = UBound(x, 1) Then Exit Do
                iCount = iCount + 1
            Loop
            If iCount + 1 <> CInt(y(j, 5)) Then
                If ii = UBound(x, 1) Then
                    If i + CInt(y(j, 5)) - 1 = UBound(x, 1) Then Exit Do
                    y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                    y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii, 2)
                    y(j + 1, 6) = ii - i - CInt(y(j, 5)) + 1: j = j + 1
                    Exit Do
                Else
                    y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                    y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii - 1, 2)
                    y(j + 1, 6) = ii - i - CInt(y(j, 5))
                End If
            Else
                j = j - 1
            End If
            iCount = 0
        End If
        i = ii
    Loop
    With Cells(4, 5).CurrentRegion.Offset(1)
        .ClearContents
        .Borders.LineStyle = xlNone
        .Resize(UBound(y, 1)) = y
    End With
    With Cells(4, 5).CurrentRegion.Resize(j + 1)
        .Borders.Weight = 2
        .Columns(1).HorizontalAlignment = xlCenter
        .Columns(5).HorizontalAlignment = xlCenter
        .Columns(6).HorizontalAlignment = xlCenter
    End With
     
End Sub

Display More

**KjBox** · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Just thought of another scenario, where the first occupied room is a higher Room Number than 1, this will cover that scenario too.

Code

Sub Summary()
    Dim x, y, i As Long, ii As Long, iCount As Integer
     
    x = Cells(1).CurrentRegion: i = 2
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Do While i <= UBound(x, 1)
        If x(i, 3) <> vbNullString Then
            ii = i + 1: j = j + 2
            If i = 2 Then j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 5) = Split(x(i, 3))(1)
            y(j, 3) = x(i, 2): y(j, 4) = x(i + y(j, 5) - 1, 2)
            Do Until x(ii, 3) <> vbNullString
                ii = ii + 1: If ii = UBound(x, 1) Then Exit Do
                iCount = iCount + 1
            Loop
            If iCount + 1 <> CInt(y(j, 5)) Then
                If ii = UBound(x, 1) Then
                    If i + CInt(y(j, 5)) - 1 = UBound(x, 1) Then Exit Do
                    y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                    y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii, 2)
                    y(j + 1, 6) = ii - i - CInt(y(j, 5)) + 1: j = j + 1
                    Exit Do
                Else
                    y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                    y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii - 1, 2)
                    y(j + 1, 6) = ii - i - CInt(y(j, 5))
                End If
            Else
                j = j - 1
            End If
            iCount = 0
        End If
        If ii = 0 Then
            j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 6) = CInt(y(j, 6)) + 1
            y(j, 3) = Left(x(i, 2), 4) & 1: y(j, 4) = x(i + y(j, 5), 2)
            i = i + 1: j = j - 1
        Else
            i = ii
        End If
    Loop
    With Cells(4, 5).CurrentRegion.Offset(1)
        .ClearContents
        .Borders.LineStyle = xlNone
        .Resize(UBound(y, 1)) = y
    End With
    With Cells(4, 5).CurrentRegion.Resize(j + 1)
        .Borders.Weight = 2
        .Columns(1).HorizontalAlignment = xlCenter
        .Columns(5).HorizontalAlignment = xlCenter
        .Columns(6).HorizontalAlignment = xlCenter
    End With
     
End Sub

Display More

ivandgreat · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Thanks again, i got an error "Subscript out of range", i just create another scenario.

**KjBox** · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Hopefully run out of scenarios by now! Try this

Code

Sub Summary()
    Dim x, y, i As Long, ii As Long, iCount As Integer
     
    x = Cells(1).CurrentRegion: i = 2
    ReDim y(1 To UBound(x, 1), 1 To 6)
    Do While i <= UBound(x, 1)
        If x(i, 3) <> vbNullString Then
            ii = i + 1: j = j + 2
            If i = 2 Then j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 5) = Split(x(i, 3))(1)
            y(j, 3) = x(i, 2): y(j, 4) = x(i + y(j, 5) - 1, 2)
            If i = UBound(x, 1) Then Exit Do
            Do Until x(ii, 3) <> vbNullString
                ii = ii + 1
                iCount = iCount + 1
                If ii > UBound(x, 1) Then Exit Do
            Loop
            If iCount + 1 <> CInt(y(j, 5)) Then
                If ii = UBound(x, 1) Then
                    If i + CInt(y(j, 5)) - 1 = UBound(x, 1) Then Exit Do
                    y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                    y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii, 2)
                    y(j + 1, 6) = ii - i - CInt(y(j, 5)) + 1: j = j + 1
                    Exit Do
                Else
                    y(j + 1, 1) = j + 1: y(j + 1, 2) = "Group" & j + 1
                    y(j + 1, 3) = x(i + y(j, 5), 2): y(j + 1, 4) = x(ii - 1, 2)
                    y(j + 1, 6) = ii - i - CInt(y(j, 5))
                End If
            Else
                j = j - 1
            End If
            iCount = 0
        End If
        If ii = 0 Then
            j = 1
            y(j, 1) = j: y(j, 2) = "Group" & j
            y(j, 6) = CInt(y(j, 6)) + 1
            y(j, 3) = Left(x(i, 2), 4) & 1: y(j, 4) = x(i + y(j, 5), 2)
            i = i + 1: j = j - 1
        Else
            i = ii
        End If
    Loop
    If ii > UBound(x, 1) Then j = j + 1
    With Cells(4, 5).CurrentRegion.Offset(1)
        .ClearContents
        .Borders.LineStyle = xlNone
        .Resize(UBound(y, 1)) = y
    End With
    With Cells(4, 5).CurrentRegion.Resize(j + 1)
        .Borders.Weight = 2
        .Columns(1).HorizontalAlignment = xlCenter
        .Columns(5).HorizontalAlignment = xlCenter
        .Columns(6).HorizontalAlignment = xlCenter
    End With
     
End Sub

Display More

ivandgreat · May 23rd 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Thanks a lot KjBox, it works fine now..

richadj4 · May 25th 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

lol, you'll have to rerun the code every time you make a change, or add summary() to the worksheet change event.

**KjBox** · May 25th 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

True, but the OP requested VBA, up to him how he chooses to use the code.

jindon · May 25th 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

Simply

Code

Sub test()
    Dim a, i As Long, ii As Long, n As Long, w, flg As Boolean
    a = Cells(1).CurrentRegion.Value
    With [e3].CurrentRegion.Offset(1)
        .ClearContents: .Borders.LineStyle = xlNone
        With CreateObject("System.Collections.ArrayList")
            For i = 2 To UBound(a, 1)
                If a(i, 3) <> "" Then
                    ReDim w(5): n = n + 1: w(0) = n: flg = False
                    w(1) = "Group" & n: w(4) = Trim$(Split(a(i, 3))(1))
                    For ii = 0 To Val(Split(a(i, 3))(1)) - 1
                        If w(2) = "" Then w(2) = a(i, 2)
                        w(3) = a(i + ii, 2)
                    Next
                    .Add w: i = i + ii - 1
                Else
                    If Not flg Then
                        n = n + 1: ReDim w(5): w(0) = n: w(2) = a(i, 2)
                        w(1) = "Group" & n: w(5) = 1: flg = True
                        .Add w
                    Else
                        w = .Item(.Count - 1)
                        w(3) = a(i, 2): w(5) = w(5) + 1
                        .Item(.Count - 1) = w
                    End If
                End If
            Next
            a = Application.Index(.ToArray, 0, 0)
        End With
        With .Resize(UBound(a, 1), 6)
            .Value = a: .Borders.Weight = 2
        End With
    End With
End Sub

Display More

ivandgreat · May 25th 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

To jindon, it also works well to all scenario except when it is empty..

jindon · May 25th 2015

Re: Excel VBA - Summary table fori Vacant and Occupied

What do you mean by "Empty"?

Excel VBA - Summary table fori Vacant and Occupied

Participate now!

Share