Extraction common data from range

jlister

Board Regular
Joined
Nov 16, 2004
Messages
56
As a relatively new user, I am looking for some assistance with a little project I have and undertake and do not know whether there is a solution in Excel or whether a macro needs to be written.

I am organising a function where on the RSVP, guests can opt to sit with other people they know will be attending.

As a database, I have set up a spreadsheet with Column "A" being the guests and Columns "B" through to "E" being who they would like to sit with. These names have been put in randomly and all of those listed in range B1:E240 are also listed in ColumnClmn A.

Each table seats 12 people and what I want to do is get Excel to allocate who sits at what table. Tables will be numbered 1 - 20.

Any assistance will be greatly appreciated.
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
This works from the list of guests down column B with columns C to E containing those they want to sit with. Each group of people in the row then determines a "set" which can be 1 to 4 people. Columns should be filled left to right.

The macro goes down the list filling each table in turn. It skips sets that are too big to fit in the remaining places until it finds space on a later table.

It uses 2 sheets called "Diners" and "Tables". The tables sheet is cleared each time, so the macro can be run if more diners appear later.

Code:
'=========================================================
'- diners
Dim Diners As Worksheet
Dim DinersetRange As Range  ' sit together
Dim DinerSet As Integer     ' number in set
Dim DinerCheckCol As String ' check set has been allocated
Dim DinersetsOK As Integer  ' count allocated sets
Dim LastRow As Long
Dim Checkrow As Long
'- tables
Dim Tables As Worksheet
Dim TableRange As Range     ' all tables
Dim TableTotals As Range    ' seats allocated
Dim CurrentTable As Integer
Dim SeatsLeft As Integer
'
'======================================
'- MAIN MACRO
'======================================
Sub test()
    Set Diners = Worksheets("Diners")
    LastRow = Diners.Range("B65536").End(xlUp).Row
    DinerCheckCol = "F"
    Diners.Columns(DinerCheckCol).ClearContents
    AllAllocated = False
    '-------------------------------------------------------
    Set Tables = Worksheets("Tables")
    Set TableRange = Tables.Range("A1:T12")
    Set TableTotals = Tables.Range("A13:T13")
    TableRange.ClearContents
    TableTotals.ClearContents
    '-------------------------------------------------------
    For CurrentTable = 1 To 20
        For Checkrow = 1 To LastRow
            DinersToSeats
            '- check if all diners have been allocated seats
            If DinersetsOK = LastRow Then
                MsgBox ("Done")
                Exit Sub
            End If
        Next
    Next
End Sub
'===========================================================
'- allocate diners to seats
Sub DinersToSeats()
    If IsEmpty(Diners.Cells(Checkrow, DinerCheckCol)) Then
        Set DinersetRange = Diners.Range("B" & Checkrow & ":E" & Checkrow)
        DinerSet = Application.WorksheetFunction.CountA(DinersetRange)
        SeatsLeft = 12 - TableTotals(CurrentTable)
        '- check enough seats left
        If SeatsLeft >= DinerSet Then
            '- allocate diner set to seats
            For d = 1 To DinerSet
                TableRange.Cells(12 - SeatsLeft + d, CurrentTable).Value = DinersetRange(d).Value
                TableTotals(CurrentTable).Value = TableTotals(CurrentTable).Value + 1
            Next
            Diners.Cells(Checkrow, DinerCheckCol).Value = "OK"
            DinersetsOK = DinersetsOK + 1
        End If
    End If
End Sub
'===========================================================
 

jlister

Board Regular
Joined
Nov 16, 2004
Messages
56
Thanks Brian

Not too sure how it should work.

I have created two new worksheets, "Diners" and "Tables" and then under the main database "Guests" I copied what you have supplied to a new MACRO and when I run the macro, all I get is an "OK" in column F of the "Diners" workbook and nothing else.

I must be doing something wrong - what could it be?

Regards
 

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
My test data in the Diners sheet is laid out like this :
Starting in Row 1, each row of data (columns B to E) consists of people who want to sit together.
Some rows may have only 1 name, others 2,3 or 4.
Names are filled in left to right. No blank cells between names.
Column B has no empty cells.
(if necessary this can be achieved by selecting the row and doing a Data/Sort left to right. Select another row and press F4 key to repeat.)

Running the macro puts the names into columns in the Tables sheet, a column for each table and a total for each table in row 13.
 

jlister

Board Regular
Joined
Nov 16, 2004
Messages
56
Thanks Brian

It is now doing what I need it to do.

Your assistance has been greatly appreciated.

I don't know what people like me would do without this site and people like you.

Regards
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,163,996
Messages
5,834,784
Members
430,322
Latest member
excelnoobnoob

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top