座位预订工作簿
Seat booking workbook
我正在尝试为我在大学管理的节目创建座位预订电子表格。我有一个所有可用座位的列表，每个座位一排，还有一个列表说明每个客户要求的座位数。
有没有什么方法可以制作一个宏来找到一块空座位，并将想要那么多座位的顾客的名字粘贴到该块中的每个单元格中？
我需要一些测试数据，所以我设想了一个这样的礼堂：
我在中间有一个实心块，翅膀在侧面呈扇形展开。在后面我有轮椅使用者的空间。我不记得曾经见过一个剧院或礼堂的每一层都不是这个主题的变体。我也不记得不是 的座位编号系统。我没有处理过多个楼层。我希望这离你的礼堂足够近，让你对自己说：“是的：我可以根据我的需要进行调整。”
听起来好像您今天需要这个系统。我记得一幅漫画：“我今天当然需要它。如果我明天需要它，我明天就会提出要求。”所以我要简单而不是优雅。
有人告诉我，好的程序的秘诀在于好的数据模型。在我看来，每排一个座位不是一个好的数据模型。我想我可以让它工作，但代码会很复杂和混乱。我的数据模型将从以下范围开始：A3-A13、B3-B13、C4-C14 等等。我发现输入所有这些范围很困难；我一直糊里糊涂。所以我切换到一个未使用的工作表并键入前两列并使用公式创建第三列：
稍后我会解释这个奇怪的序列。您可能比我更擅长输入范围，因此不需要这个中间步骤。
然后我将第 3 列中的 值 复制到工作表“可用”以创建：
我把这四天命名为星期一到星期四。您可以使用任何四个字符串，只要它们不同即可。我把座位分为两种类型：“普通”和“轮椅用户”。您可以为前面的行设置一个价格，为后面的行设置另一个价格，或者任何其他可能合适的分区。每个部门每天需要一列，每个部门需要一个名称。因为每个分区的座位是独立分配的，所以必须单独列。
我答应解释这个奇怪的序列。除了一个例外（如下所述），第一排的所有座位都将在第二排的任何座位之前分配。我决定在开始使用侧翼的座位之前先填满中间部分的前四排。因为系统从顶部开始并向下工作，所以您可以控制分配范围的顺序。您可能不需要该功能，但如果您需要，它是免费的。
在考虑 B3-B13 之前填写 A3-A13 的例外情况是因为您不希望在行尾有奇数座位。我认为大多数预订都是针对单身人士、三人组等场合的情侣。如果预订意味着 A12 会被填满但 A13 不会被填满，则该预订将分配给 B3-B13 区块。除非没有更好的选择，否则 A3-A13 组的最后一个座位只会被与剩余座位匹配的预订填满。
你说你有“一张清单，上面写着每个顾客要求的座位数”。我生成了一些随机预订以获得：
如果您当前的列表合并了名字和姓氏，那么我们将遇到拆分问题，因为我真的相信我们需要将它们分开。 “Day”和“Part”对应于工作表“Available”中的列标题。通过组合这些值，系统知道哪个列适合此预订。大多数测试预订都是两个座位，也有少量的一人座、三人座和四人座。一个预订是系统无法处理的十四个座位。根据我的经验，大型团体会在相邻的行中获得匹配的座位（例如：A3-A9 和 B3-B9）。您将不得不手动处理此类请求。
宏 Allocate 可以根据需要 运行 执行。您在工作表“新预订”和 运行 宏中键入一些预订。宏检查列表中的每个预订，为其分配座位，从工作表“可用”中删除分配的座位，将分配的详细信息添加到工作表“已分配”并将已处理的预订移至工作表已处理。通常我会在数组中处理所有这些，但我认为如果它在工作表之外运行会更容易编码和理解。 运行将我的测试数据与我的可用数据进行比较的结果是：
只有无法处理的预订才会保留在工作表“新预订”中。已添加无法处理预订的原因。
请注意，A、B 等行已从 Available 中消失，因为它们已被分配。
“已分配”工作表是您需要的任何报告的来源。您可以按名称或座位排序以获得不同的列表。你可以打印门票。你可以建立一个“auditoium” 预订视图，如您在问题中建议的那样。
Allocate 和 Check 这两个宏在单独的答案中，因为我已经超出了答案的字符数限制。
Allocate 执行上述分配过程。
Check 验证工作表“可用”和“已分配”。 Allocate 更新了四个必须同步的工作簿。一个模糊的错误可能意味着一个座位被分配了两次或者从系统中丢失了。我已经彻底测试了 Allocate 但我不能保证它没有错误。通过 运行ning Check，您将能够立即检测到任何错误的影响。
我建议你仔细测试Allocate。在宏未使用的工作表中保留预订和可用座位的副本。
如果遇到错误，您可能需要将数据的副本发送给我。查看我的个人资料以获取电子邮件地址。
上图显示了宏使用的四个工作表。它们也在宏中得到了完整的解释。你的帖子在我早上的 1:00 或 2:00，所以我猜你在美国西海岸。不幸的是，这几乎最大化了我们通信的周转时间。
祝你使用宏好运。
有关此代码的说明，请参阅 。
这是第二次发帖。我对宏 Allocate.
做了一些小改动
Option Explicit
' Constants make the code more readable and make it easier to rearrange columns
' if necessary since changing the constant changes every use. If you had ever
' examined every 2 in a large block of code and had to decide if it was a reference
' to a particular column in a particular worksheet, you would understand why I use
' constants so heavily.
' Columns within worksheet "New bookings"
Const ColNewBkFirst As Long = 1 ' This and ColNextLast allow columns to be
' rearranged at will.
Const ColNewBkFamily As Long = 1
Const ColNewBkGiven As Long = 2
Const ColNewBkDay As Long = 3
Const ColNewBkPart As Long = 4
Const ColNewBkRequired As Long = 5
Const ColNewBkError As Long = 6
Const ColNewBkLast As Long = 5 ' Do not include error column
' which must be rightmost column
' Offsets within worksheet "Allocated"
Const OffsetAllocFamily As Long = 0 ' \ Offsets on column found
Const OffsetAllocGiven As Long = 1 ' | in header row to have
Const OffsetAllocSeats As Long = 2 ' / required Day name
' First data rows in worksheets
Const RowAllocDataFirst As Long = 3
Const RowAvailDataFirst As Long = 3
Const RowNewBkDataFirst As Long = 2
Const RowProcDataFirst As Long = 2
Const WidthAllocGroup As Long = 3 ' Number of columns for a Day
' in worksheet "Allocated"
Sub Allocate()
' * This macro updates 4 worksheets. Excel does not provide the all
' updates of a block or none functionality of a database so the
' macro performs as many checks as it can to make sure that the
' four updates are all performed.
' * Errors in worksheet "New bookings" will result in an error
' message against the booking which will not have resulted in updates
' to the other worksheets. Correct the error and rerun the macro.
' * Errors in worksheet "Available" are fatal. Any bookings already
' processed should be fine. The booking that caused the error to be
' discovered will not have been processed. Correct the error and
' rerun the macro.
' * Errors in worksheet "Allocated" will be reported as errors against
' the booking. Correct the error and rerun the macro.
' * Processed bookings are moved to worksheet "Processed". If you keep
' an original copy of worksheet "Available" then by replacing the
' updated "Available", copying the rows in "Processed" to
' "New bookings" and clearing "Allocated", you could restart the
' allocation process in the event of a disaster.
' * The four updates for a successfully processed booking are:
' - Booking deleted from "New bookings".
' - A range of available seats in "Available" will have been updated
' or deleted. For example a booking for 2 seats will replace "A3-A13"
' by "A5-A13" or will delete "A12-A13".
' - The customer's name and the seat range will have been added to
' "Allocated".
' - Booking added to "Processed"
' This stops odd seats being left at the end of seat ranges. Given the
' range "A11-A13", a booking for two seats would not be matched aginast it
' because if would leave one seat "A13". I do not think a value other
' than 2 would be sensible but I have not experimented. This rule is
' ignored if no other way of fulfilling a booking is found.
Const MinSeatsInRange As Long = 2
Dim Allocation As String
Dim ColAllocCrnt As Long
Dim ColAvailCrnt As Long
Dim ErrorCrnt As String
Dim FamilyNameCrnt As String
Dim GivenNameCrnt As String
Dim DayCrnt As String
Dim NameAvailCol As String
Dim PartCrnt As String
Dim RequiredCrnt As Long
Dim RowAllocNext As Long
Dim RowAvailCrnt As Long
Dim RowAvailLast As Long
Dim RowAvailPoss As Long
Dim RowNewBkCrnt As Long
Dim RowProcNext As Long
Dim SeatRange As String
Dim SeatRangeRowCode As String
Dim SeatRangeNumberFirst As Long
Dim SeatRangeNumberLast As Long
Dim SeatRangeCount As Long
Application.ScreenUpdating = False ' Without this the macro will be very slow
' Find next free row in worksheet "Processed"
With Worksheets("Processed")
RowProcNext = .Cells(Rows.Count, ColNewBkFamily).End(xlUp).Row + 1
End With
' I cannot use a For-Loop for worksheet "New bookings" because I
' am deleting rows. The Do loop continues until it find a row
' with a blank family name.
RowNewBkCrnt = RowNewBkDataFirst
Do While True
' Copy booking to variables and perform internal checks.
With Worksheets("New bookings")
ErrorCrnt = "" ' Ig nore any error message remainign from a previous run
FamilyNameCrnt = .Cells(RowNewBkCrnt, ColNewBkFamily).Value
If FamilyNameCrnt = "" Then
' All new bookings processed
Exit Do
End If
GivenNameCrnt = .Cells(RowNewBkCrnt, ColNewBkGiven).Value
DayCrnt = .Cells(RowNewBkCrnt, ColNewBkDay).Value
PartCrnt = .Cells(RowNewBkCrnt, ColNewBkPart).Value
If IsNumeric(.Cells(RowNewBkCrnt, ColNewBkRequired).Value) Then
RequiredCrnt = .Cells(RowNewBkCrnt, ColNewBkRequired).Value
If RequiredCrnt < 1 Then
ErrorCrnt = "Required must be 1 or more"
End If
Else
ErrorCrnt = "Required not numeric"
End If
End With
'Debug.Assert Not (DayCrnt = "Wednesday" And RequiredCrnt = 4)
' Find some seats that match the booking
With Worksheets("Available")
Allocation = ""
RowAvailPoss = 0
' All following code is within "If ErrorCrnt = "" Then" to
' "End If" blocks. This means once an error is detected
' all other processing code is skipped.
If ErrorCrnt = "" Then
' Find column for Day and Part
' Combine Day and Part to create column heading
NameAvailCol = DayCrnt & _
IIf(PartCrnt <> "", " " & PartCrnt, "")
' Search along row 1 for expected column heading
ColAvailCrnt = 1
Do While True
If .Cells(1, ColAvailCrnt).Value = NameAvailCol Then
' Required column found
Exit Do
End If
ColAvailCrnt = ColAvailCrnt + 1
If .Cells(1, ColAvailCrnt).Value = "" Then
' No matching column exists
ErrorCrnt = "No column in worksheet Available has heading """ & _
NameAvailCol & """"
Exit Do
End If
Loop
End If ' ErrorCrnt = ""
' Find range from which to allocate seats
If ErrorCrnt = "" Then
RowAvailLast = .Cells(Rows.Count, ColAvailCrnt).End(xlUp).Row
For RowAvailCrnt = RowAvailDataFirst To RowAvailLast
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
' Fatal error
Debug.Print ErrorCrnt
Worksheets("Allocated").Activate
Call MsgBox(ErrorCrnt, vbOKOnly)
Exit Sub
End If
' Compare booking against seat range
If ErrorCrnt = "" Then
If RequiredCrnt > SeatRangeCount Then
' This range is not big enough
ElseIf RequiredCrnt = SeatRangeCount Then
' This range is exactly the right size
' Have leading zero because sort places "A1-A2" after "A11-A12" and
' "A1" after "A02-03"
Allocation = SeatRangeRowCode & Right("0" & SeatRangeNumberFirst, 2)
If RequiredCrnt > 1 Then
Allocation = Allocation & "-" & SeatRangeRowCode & _
Right("0" & SeatRangeNumberFirst + RequiredCrnt - 1, 2)
End If
SeatRange = ""
ElseIf SeatRangeCount - RequiredCrnt < MinSeatsInRange Then
' Removing this requirement from this range
' would leave too small a remainder
If RowAvailPoss = 0 Then
' If no better means of fulfilling booking is found,
' this range will be accepted.
RowAvailPoss = RowAvailCrnt
End If
Else
' Range is more than big enough. Record seat range allocated to booking
' and calculate reduced range to be written back to "Available".
' Have leading zeroes because sort places "A1-A2" after "A11-A12" and
' "A1" after "A02-03"
Allocation = SeatRangeRowCode & Right("0" & SeatRangeNumberFirst, 2)
If RequiredCrnt > 1 Then
Allocation = Allocation & "-" & SeatRangeRowCode & _
Right("0" & SeatRangeNumberFirst + RequiredCrnt - 1, 2)
End If
SeatRange = SeatRangeRowCode & SeatRangeNumberFirst + RequiredCrnt
If SeatRangeNumberFirst + RequiredCrnt < SeatRangeNumberLast Then
SeatRange = SeatRange & "-" & SeatRangeRowCode & SeatRangeNumberLast
End If
End If
End If
If ErrorCrnt <> "" Then
Exit For
End If
If Allocation <> "" Then
' Required seats extracted from this range.
' Ignore remainder of Available column
Exit For
End If
Next ' RowAvailCrnt
End If ' ErrorCrnt = ""
If ErrorCrnt = "" Then
If Allocation = "" Then
If RowAvailPoss <> 0 Then
' A possible range was found but using it would have left an
' odd seat. Since nothing better has been found, use it
RowAvailCrnt = RowAvailPoss
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
' Fatal error. Should not be possible since range already decoded
Debug.Print ErrorCrnt
Worksheets("Allocated").Activate
Call MsgBox(ErrorCrnt, vbOKOnly)
Exit Sub
End If
' Know range is big enough so no need to check again
' Have leading zeroes because sort places "A1-A2" after "A11-A12" and
' "A1" after "A02-03"
Allocation = SeatRangeRowCode & Right("0" & SeatRangeNumberFirst, 2)
If RequiredCrnt > 1 Then
Allocation = Allocation & "-" & SeatRangeRowCode & _
SeatRangeNumberFirst + RequiredCrnt - 1
End If
SeatRange = SeatRangeRowCode & SeatRangeNumberFirst + RequiredCrnt
If SeatRangeNumberFirst + RequiredCrnt < SeatRangeNumberLast Then
SeatRange = SeatRange & "-" & SeatRangeRowCode & SeatRangeNumberLast
End If
Else
' No seat range big enough for RequiredCrnt was found
ErrorCrnt = "No range was found big enough to allow allocation of " & _
RequiredCrnt & " seats"
End If
End If
End If
End With
If ErrorCrnt = "" Then
' Find appropriate column in worksheet "Allocated"
With Worksheets("Allocated")
ColAllocCrnt = 1
Do While True
If .Cells(1, ColAllocCrnt).Value = DayCrnt Then
' Required column found
Exit Do
End If
' Step to set of columns for next day
ColAllocCrnt = ColAllocCrnt + WidthAllocGroup
If .Cells(1, ColAllocCrnt).Value = "" Then
' No matching column exists
'Debug.Assert False
ErrorCrnt = "No column in worksheet Allocated has heading """ & DayCrnt & """"
Exit Do
End If
Loop
End With
End If
If ErrorCrnt = "" Then
' No errors found. Perform all updates for this booking.
With Worksheets("Allocated")
RowAllocNext = .Cells(Rows.Count, ColAllocCrnt).End(xlUp).Row + 1
.Cells(RowAllocNext, ColAllocCrnt + OffsetAllocFamily).Value = FamilyNameCrnt
.Cells(RowAllocNext, ColAllocCrnt + OffsetAllocGiven).Value = GivenNameCrnt
.Cells(RowAllocNext, ColAllocCrnt + OffsetAllocSeats).Value = Allocation
End With
With Worksheets("Available")
If SeatRange = "" Then
' The range from which the allocate was made
' is now empty so delete it.
.Cells(RowAvailCrnt, ColAvailCrnt).Delete Shift:=xlUp
Else
' Range not cleared. Replaced old range with reduced range
.Cells(RowAvailCrnt, ColAvailCrnt).Value = SeatRange
End If
End With
With Worksheets("New bookings")
' Copy processed booking to worksheet Processed
.Range(.Cells(RowNewBkCrnt, ColNewBkFirst), .Cells(RowNewBkCrnt, ColNewBkLast)).Copy _
Destination:=Worksheets("Processed").Cells(RowProcNext, 1)
RowProcNext = RowProcNext + 1
' Delete processed booking
.Rows(RowNewBkCrnt).EntireRow.Delete
End With
' Note: No need to update RowNewBkCrnt because next row has moved up
Else
' A non-fatal error has occurred. Record it against the request.
With Worksheets("New bookings")
.Cells(RowNewBkCrnt, ColNewBkError).Value = ErrorCrnt
End With
RowNewBkCrnt = RowNewBkCrnt + 1 ' Update RowNextCrnt so this row is preserved
End If
Loop ' Until all new booking processed or abandoned
Application.ScreenUpdating = True
End Sub
有关此代码的说明，请参阅 。
这是第二次发帖。我在宏 Check.
中添加了另一个级别的检查
Sub Check()
' Check there are no duplicate or missing seats.
' Report any errors found to the Immediate Window.
Dim ColAllocCrnt As Long
Dim ColAvailCrnt As Long
Dim ColSeatCrnt As Long
Dim DayCrnt As String
Dim ErrorCount As Long
Dim ErrorCrnt As String
Dim RowAllocCrnt As Long
Dim RowAllocLast As Long
Dim RowAvailCrnt As Long
Dim RowAvailLast As Long
Dim RowSeatCrnt As Long
Dim SeatNumberMax As Long
Dim SeatRecorded() As String
Dim SeatRecordedPart() As String
Dim SeatRowCodeMax As String
Dim SeatRowNumber As String
Dim SeatRange As String
Dim SeatRangeRowCode As String
Dim SeatRangeNumberFirst As Long
Dim SeatRangeNumberLast As Long
Dim SeatRangeCount As Long
' Loop for each day recorded in worksheet "Available"
ColAllocCrnt = 1
Do While True
With Worksheets("Allocated")
If .Cells(1, ColAllocCrnt).Value = "" Then
' All days analysed
Exit Do
End If
DayCrnt = .Cells(1, ColAllocCrnt).Value
End With
Debug.Print "Checking seats for " & DayCrnt
ErrorCount = 0
' It it not possible to increase the number of columns in an array so
' scan worksheets "Allocated" and "Available" for maximum row code
' and seat number.
SeatNumberMax = 0
SeatRowCodeMax = ""
With Worksheets("Allocated")
' ColAllocCrnt identifies the column for the current day
' Find maximum row code and seat letter in worksheet "Allocated"
' for current day
RowAllocLast = .Cells(Rows.Count, ColAllocCrnt).End(xlUp).Row
For RowAllocCrnt = RowAllocDataFirst To RowAllocLast
SeatRange = .Cells(RowAllocCrnt, ColAllocCrnt + OffsetAllocSeats).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
Debug.Print ErrorCrnt
ErrorCount = ErrorCount + 1
Else
If SeatNumberMax < SeatRangeNumberLast Then
' Record new highest seat number
SeatNumberMax = SeatRangeNumberLast
End If
If SeatRowCodeMax < SeatRangeRowCode Then
' Record new highest seat row code
SeatRowCodeMax = SeatRangeRowCode
End If
End If
Next
End With
With Worksheets("Available")
' There may be multiple columns in worksheet "Available" for the current day
ColAvailCrnt = 1
Do While True
If .Cells(1, ColAvailCrnt).Value = "" Then
' All columns in worksheet "Available" examined
Exit Do
End If
If Left(.Cells(1, ColAvailCrnt).Value, Len(DayCrnt)) = DayCrnt Then
' This column is for the current day
' Review SeatNumberMax and SeatRowCodeMax for available ranges
RowAvailLast = .Cells(Rows.Count, ColAvailCrnt).End(xlUp).Row
For RowAvailCrnt = RowAvailDataFirst To RowAvailLast
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
Debug.Print ErrorCrnt
ErrorCount = ErrorCount + 1
Else
If SeatNumberMax < SeatRangeNumberLast Then
' Record new highest seat number
SeatNumberMax = SeatRangeNumberLast
End If
If SeatRowCodeMax < SeatRangeRowCode Then
' Record new highest seat row code
SeatRowCodeMax = SeatRangeRowCode
End If
End If
Next
End If
ColAvailCrnt = ColAvailCrnt + 1
Loop
End With
Debug.Print " " & SeatRowCodeMax & SeatNumberMax
SeatRowNumber = Asc(SeatRowCodeMax) - Asc("A") + 1
' Size array so there is room for every possible seat
' Note: cells will be initialised to empty
ReDim RowSeatRecorded(1 To SeatNumberMax, 1 To SeatRowNumber)
' * Record workssheet, row and column on which each seat is recorded.
' Format is X:Row:Col where X is L for "Allocated" and V for "Available".
' * No seat should be recorded more than once. Report any duplicates.
With Worksheets("Allocated")
RowAllocLast = .Cells(Rows.Count, ColAllocCrnt).End(xlUp).Row
For RowAllocCrnt = RowAllocDataFirst To RowAllocLast
SeatRange = .Cells(RowAllocCrnt, ColAllocCrnt + OffsetAllocSeats).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAllocCrnt, ColAllocCrnt)
If ErrorCrnt <> "" Then
' Error already reported
Else
SeatRowNumber = Asc(SeatRangeRowCode) - Asc("A") + 1
For ColSeatCrnt = SeatRangeNumberFirst To SeatRangeNumberLast
If RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = 0 Then
' First occurrence of this seat number
RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = _
"L:" & RowAllocCrnt & ":" & ColAllocCrnt + OffsetAllocSeats
Else
' Duplicate recording of seat
Debug.Print " " & GenDuplicateSeatError(SeatRangeRowCode & ColSeatCrnt, _
RowSeatRecorded(ColSeatCrnt, SeatRowNumber), "L", _
RowAllocCrnt, ColAllocCrnt + OffsetAllocSeats)
ErrorCount = ErrorCount + 1
End If
Next
End If
Next
End With
With Worksheets("Available")
' There may be multiple columns in worksheet "Available" for the current day
ColAvailCrnt = 1
Do While True
If .Cells(1, ColAvailCrnt).Value = "" Then
' All columns in worksheet "Available" examined
Exit Do
End If
If Left(.Cells(1, ColAvailCrnt).Value, Len(DayCrnt)) = DayCrnt Then
' This column is for the current day
RowAvailLast = .Cells(Rows.Count, ColAvailCrnt).End(xlUp).Row
For RowAvailCrnt = RowAvailDataFirst To RowAvailLast
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
' Already reported
Else
SeatRowNumber = Asc(SeatRangeRowCode) - Asc("A") + 1
For ColSeatCrnt = SeatRangeNumberFirst To SeatRangeNumberLast
If RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = 0 Then
' First occurrence of this seat number
RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = "V:" & RowAvailCrnt & ":" & ColAvailCrnt
Else
' Duplicate recording of seat
Debug.Print " " & GenDuplicateSeatError(SeatRangeRowCode & ColSeatCrnt, _
RowSeatRecorded(ColSeatCrnt, SeatRowNumber), "V", _
RowAvailCrnt, ColAvailCrnt)
ErrorCount = ErrorCount + 1
End If
Next
End If
Next
End If
ColAvailCrnt = ColAvailCrnt + 1
Loop
End With
' Look for gaps in the array of seats.
For RowSeatCrnt = 1 To UBound(RowSeatRecorded, 2)
' Scan for recorded seat
For ColSeatCrnt = UBound(RowSeatRecorded, 1) To 1 Step -1
If RowSeatRecorded(ColSeatCrnt, RowSeatCrnt) <> "" Then
' This seat recorded
Exit For
End If
Next
' Scan for gap between last recorded seat and first
For ColSeatCrnt = ColSeatCrnt - 1 To 1 Step -1
If RowSeatRecorded(ColSeatCrnt, RowSeatCrnt) = "" Then
Debug.Print " Seat " & Chr(RowSeatCrnt + 64) & ColSeatCrnt & " not found"
ErrorCount = ErrorCount + 1
End If
Next
Next
Debug.Print " " & ErrorCount & " errors found"
ColAllocCrnt = ColAllocCrnt + WidthAllocGroup
Loop ' For each day in worksheet "Allocated
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function
Sub DecodeSeatRange(ByVal SeatRange As String, ByRef RowCode As String, _
ByRef NumberFirst As Long, ByRef NumberLast As Long, _
ByRef Count As Long, ByRef ErrorMsg As String, _
ByVal RowAvail As Long, ByVal ColAvail As Long)
' * Split a seat range into it components.
' * A seat range is:
' RowCode Number
' or RowCode Number - RowCode Number
' * The two RowCodes must be the same.
' * The numbers must be one or more and Last cannot be less than First
' * If ErrorMsg = "" or return, the seat range has been successfully
' decoded. Otherwise it reports the error found.
Dim RangePart() As String
RangePart = Split(SeatRange, "-")
If UBound(RangePart) = 0 Then
' Have single seat range.
' Extract seat details into variables and perform internal checks
RowCode = Mid(SeatRange, 1, 1)
If IsNumeric(Mid(SeatRange, 2)) Then
NumberFirst = Mid(SeatRange, 2)
NumberLast = NumberFirst
Count = 1
Else
ErrorMsg = "Seat number is not numeric"
End If
Else
' Have normal seat range; Xn-Ym.
' Split range details into variables and perform internal checks
RowCode = Mid(RangePart(0), 1, 1)
If RowCode <> Mid(RangePart(1), 1, 1) Then
ErrorMsg = "Fatal error in worksheet ""Available"". Range in cell " & _
ColNumToCode(ColAvail) & RowAvail & " is not a single row"
Else
If Not IsNumeric(Mid(RangePart(0), 2)) Then
ErrorMsg = "Fatal error in worksheet Available. Start of range in cell " & _
ColNumToCode(ColAvail) & RowAvail & _
" is not <RowCode><Number>"
Else
NumberFirst = Mid(RangePart(0), 2)
If Not IsNumeric(Mid(RangePart(1), 2)) Then
ErrorMsg = "Fatal error in worksheet Available. End of range in cell " & _
ColNumToCode(ColAvail) & RowAvail & _
" is not <RowCode><Number>"
Else
NumberLast = Mid(RangePart(1), 2)
Count = NumberLast - NumberFirst + 1
If Count > 0 Then
' Good range
Else
' Bad range
ErrorMsg = "Fatal error in worksheet Available. " & _
"Start of range after end of range cell " & _
ColNumToCode(ColAvail) & RowAvail
End If
End If
End If
End If
End If ' single seat/multiple seat range
End Sub
Function GenDuplicateSeatError(ByVal Seat As String, ByVal Record As String, _
ByVal WshtCode As String, ByVal RowCrnt As Long, _
ByVal ColCrnt As Long) As String
' * Record contained details of a previous encounter of a seat. Its format is
' X:Row:Column where X is "L" for worksheet "Allocated" or "V" for worksheet
' "Available".
' * WshtCode, RowCrnt and ColCrnt identify a second or subsequent encounter
' of the seat. Generate a suitable error message.
Dim RecordPart() As String
RecordPart = Split(Record, ":")
GenDuplicateSeatError = "Seat " & Seat & " is recorded in " & _
IIf(RecordPart(0) = "L", "Allocated", "Available") & "." & _
ColNumToCode(Val(RecordPart(2))) & RecordPart(1) & " and " & _
IIf(WshtCode = "L", "Allocated", "Available") & "." & _
ColNumToCode(ColCrnt) & RowCrnt
End Function
我正在尝试为我在大学管理的节目创建座位预订电子表格。我有一个所有可用座位的列表，每个座位一排，还有一个列表说明每个客户要求的座位数。
有没有什么方法可以制作一个宏来找到一块空座位，并将想要那么多座位的顾客的名字粘贴到该块中的每个单元格中？
我需要一些测试数据，所以我设想了一个这样的礼堂：
我在中间有一个实心块，翅膀在侧面呈扇形展开。在后面我有轮椅使用者的空间。我不记得曾经见过一个剧院或礼堂的每一层都不是这个主题的变体。我也不记得不是
听起来好像您今天需要这个系统。我记得一幅漫画：“我今天当然需要它。如果我明天需要它，我明天就会提出要求。”所以我要简单而不是优雅。
有人告诉我，好的程序的秘诀在于好的数据模型。在我看来，每排一个座位不是一个好的数据模型。我想我可以让它工作，但代码会很复杂和混乱。我的数据模型将从以下范围开始：A3-A13、B3-B13、C4-C14 等等。我发现输入所有这些范围很困难；我一直糊里糊涂。所以我切换到一个未使用的工作表并键入前两列并使用公式创建第三列：
稍后我会解释这个奇怪的序列。您可能比我更擅长输入范围，因此不需要这个中间步骤。
然后我将第 3 列中的 值 复制到工作表“可用”以创建：
我把这四天命名为星期一到星期四。您可以使用任何四个字符串，只要它们不同即可。我把座位分为两种类型：“普通”和“轮椅用户”。您可以为前面的行设置一个价格，为后面的行设置另一个价格，或者任何其他可能合适的分区。每个部门每天需要一列，每个部门需要一个名称。因为每个分区的座位是独立分配的，所以必须单独列。
我答应解释这个奇怪的序列。除了一个例外（如下所述），第一排的所有座位都将在第二排的任何座位之前分配。我决定在开始使用侧翼的座位之前先填满中间部分的前四排。因为系统从顶部开始并向下工作，所以您可以控制分配范围的顺序。您可能不需要该功能，但如果您需要，它是免费的。
在考虑 B3-B13 之前填写 A3-A13 的例外情况是因为您不希望在行尾有奇数座位。我认为大多数预订都是针对单身人士、三人组等场合的情侣。如果预订意味着 A12 会被填满但 A13 不会被填满，则该预订将分配给 B3-B13 区块。除非没有更好的选择，否则 A3-A13 组的最后一个座位只会被与剩余座位匹配的预订填满。
你说你有“一张清单，上面写着每个顾客要求的座位数”。我生成了一些随机预订以获得：
如果您当前的列表合并了名字和姓氏，那么我们将遇到拆分问题，因为我真的相信我们需要将它们分开。 “Day”和“Part”对应于工作表“Available”中的列标题。通过组合这些值，系统知道哪个列适合此预订。大多数测试预订都是两个座位，也有少量的一人座、三人座和四人座。一个预订是系统无法处理的十四个座位。根据我的经验，大型团体会在相邻的行中获得匹配的座位（例如：A3-A9 和 B3-B9）。您将不得不手动处理此类请求。
宏 Allocate 可以根据需要 运行 执行。您在工作表“新预订”和 运行 宏中键入一些预订。宏检查列表中的每个预订，为其分配座位，从工作表“可用”中删除分配的座位，将分配的详细信息添加到工作表“已分配”并将已处理的预订移至工作表已处理。通常我会在数组中处理所有这些，但我认为如果它在工作表之外运行会更容易编码和理解。 运行将我的测试数据与我的可用数据进行比较的结果是：
只有无法处理的预订才会保留在工作表“新预订”中。已添加无法处理预订的原因。
请注意，A、B 等行已从 Available 中消失，因为它们已被分配。
“已分配”工作表是您需要的任何报告的来源。您可以按名称或座位排序以获得不同的列表。你可以打印门票。你可以建立一个“auditoium” 预订视图，如您在问题中建议的那样。
Allocate 和 Check 这两个宏在单独的答案中，因为我已经超出了答案的字符数限制。
Allocate 执行上述分配过程。
Check 验证工作表“可用”和“已分配”。 Allocate 更新了四个必须同步的工作簿。一个模糊的错误可能意味着一个座位被分配了两次或者从系统中丢失了。我已经彻底测试了 Allocate 但我不能保证它没有错误。通过 运行ning Check，您将能够立即检测到任何错误的影响。
我建议你仔细测试Allocate。在宏未使用的工作表中保留预订和可用座位的副本。
如果遇到错误，您可能需要将数据的副本发送给我。查看我的个人资料以获取电子邮件地址。
上图显示了宏使用的四个工作表。它们也在宏中得到了完整的解释。你的帖子在我早上的 1:00 或 2:00，所以我猜你在美国西海岸。不幸的是，这几乎最大化了我们通信的周转时间。
祝你使用宏好运。
有关此代码的说明，请参阅
这是第二次发帖。我对宏 Allocate.
Option Explicit
' Constants make the code more readable and make it easier to rearrange columns
' if necessary since changing the constant changes every use. If you had ever
' examined every 2 in a large block of code and had to decide if it was a reference
' to a particular column in a particular worksheet, you would understand why I use
' constants so heavily.
' Columns within worksheet "New bookings"
Const ColNewBkFirst As Long = 1 ' This and ColNextLast allow columns to be
' rearranged at will.
Const ColNewBkFamily As Long = 1
Const ColNewBkGiven As Long = 2
Const ColNewBkDay As Long = 3
Const ColNewBkPart As Long = 4
Const ColNewBkRequired As Long = 5
Const ColNewBkError As Long = 6
Const ColNewBkLast As Long = 5 ' Do not include error column
' which must be rightmost column
' Offsets within worksheet "Allocated"
Const OffsetAllocFamily As Long = 0 ' \ Offsets on column found
Const OffsetAllocGiven As Long = 1 ' | in header row to have
Const OffsetAllocSeats As Long = 2 ' / required Day name
' First data rows in worksheets
Const RowAllocDataFirst As Long = 3
Const RowAvailDataFirst As Long = 3
Const RowNewBkDataFirst As Long = 2
Const RowProcDataFirst As Long = 2
Const WidthAllocGroup As Long = 3 ' Number of columns for a Day
' in worksheet "Allocated"
Sub Allocate()
' * This macro updates 4 worksheets. Excel does not provide the all
' updates of a block or none functionality of a database so the
' macro performs as many checks as it can to make sure that the
' four updates are all performed.
' * Errors in worksheet "New bookings" will result in an error
' message against the booking which will not have resulted in updates
' to the other worksheets. Correct the error and rerun the macro.
' * Errors in worksheet "Available" are fatal. Any bookings already
' processed should be fine. The booking that caused the error to be
' discovered will not have been processed. Correct the error and
' rerun the macro.
' * Errors in worksheet "Allocated" will be reported as errors against
' the booking. Correct the error and rerun the macro.
' * Processed bookings are moved to worksheet "Processed". If you keep
' an original copy of worksheet "Available" then by replacing the
' updated "Available", copying the rows in "Processed" to
' "New bookings" and clearing "Allocated", you could restart the
' allocation process in the event of a disaster.
' * The four updates for a successfully processed booking are:
' - Booking deleted from "New bookings".
' - A range of available seats in "Available" will have been updated
' or deleted. For example a booking for 2 seats will replace "A3-A13"
' by "A5-A13" or will delete "A12-A13".
' - The customer's name and the seat range will have been added to
' "Allocated".
' - Booking added to "Processed"
' This stops odd seats being left at the end of seat ranges. Given the
' range "A11-A13", a booking for two seats would not be matched aginast it
' because if would leave one seat "A13". I do not think a value other
' than 2 would be sensible but I have not experimented. This rule is
' ignored if no other way of fulfilling a booking is found.
Const MinSeatsInRange As Long = 2
Dim Allocation As String
Dim ColAllocCrnt As Long
Dim ColAvailCrnt As Long
Dim ErrorCrnt As String
Dim FamilyNameCrnt As String
Dim GivenNameCrnt As String
Dim DayCrnt As String
Dim NameAvailCol As String
Dim PartCrnt As String
Dim RequiredCrnt As Long
Dim RowAllocNext As Long
Dim RowAvailCrnt As Long
Dim RowAvailLast As Long
Dim RowAvailPoss As Long
Dim RowNewBkCrnt As Long
Dim RowProcNext As Long
Dim SeatRange As String
Dim SeatRangeRowCode As String
Dim SeatRangeNumberFirst As Long
Dim SeatRangeNumberLast As Long
Dim SeatRangeCount As Long
Application.ScreenUpdating = False ' Without this the macro will be very slow
' Find next free row in worksheet "Processed"
With Worksheets("Processed")
RowProcNext = .Cells(Rows.Count, ColNewBkFamily).End(xlUp).Row + 1
End With
' I cannot use a For-Loop for worksheet "New bookings" because I
' am deleting rows. The Do loop continues until it find a row
' with a blank family name.
RowNewBkCrnt = RowNewBkDataFirst
Do While True
' Copy booking to variables and perform internal checks.
With Worksheets("New bookings")
ErrorCrnt = "" ' Ig nore any error message remainign from a previous run
FamilyNameCrnt = .Cells(RowNewBkCrnt, ColNewBkFamily).Value
If FamilyNameCrnt = "" Then
' All new bookings processed
Exit Do
End If
GivenNameCrnt = .Cells(RowNewBkCrnt, ColNewBkGiven).Value
DayCrnt = .Cells(RowNewBkCrnt, ColNewBkDay).Value
PartCrnt = .Cells(RowNewBkCrnt, ColNewBkPart).Value
If IsNumeric(.Cells(RowNewBkCrnt, ColNewBkRequired).Value) Then
RequiredCrnt = .Cells(RowNewBkCrnt, ColNewBkRequired).Value
If RequiredCrnt < 1 Then
ErrorCrnt = "Required must be 1 or more"
End If
Else
ErrorCrnt = "Required not numeric"
End If
End With
'Debug.Assert Not (DayCrnt = "Wednesday" And RequiredCrnt = 4)
' Find some seats that match the booking
With Worksheets("Available")
Allocation = ""
RowAvailPoss = 0
' All following code is within "If ErrorCrnt = "" Then" to
' "End If" blocks. This means once an error is detected
' all other processing code is skipped.
If ErrorCrnt = "" Then
' Find column for Day and Part
' Combine Day and Part to create column heading
NameAvailCol = DayCrnt & _
IIf(PartCrnt <> "", " " & PartCrnt, "")
' Search along row 1 for expected column heading
ColAvailCrnt = 1
Do While True
If .Cells(1, ColAvailCrnt).Value = NameAvailCol Then
' Required column found
Exit Do
End If
ColAvailCrnt = ColAvailCrnt + 1
If .Cells(1, ColAvailCrnt).Value = "" Then
' No matching column exists
ErrorCrnt = "No column in worksheet Available has heading """ & _
NameAvailCol & """"
Exit Do
End If
Loop
End If ' ErrorCrnt = ""
' Find range from which to allocate seats
If ErrorCrnt = "" Then
RowAvailLast = .Cells(Rows.Count, ColAvailCrnt).End(xlUp).Row
For RowAvailCrnt = RowAvailDataFirst To RowAvailLast
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
' Fatal error
Debug.Print ErrorCrnt
Worksheets("Allocated").Activate
Call MsgBox(ErrorCrnt, vbOKOnly)
Exit Sub
End If
' Compare booking against seat range
If ErrorCrnt = "" Then
If RequiredCrnt > SeatRangeCount Then
' This range is not big enough
ElseIf RequiredCrnt = SeatRangeCount Then
' This range is exactly the right size
' Have leading zero because sort places "A1-A2" after "A11-A12" and
' "A1" after "A02-03"
Allocation = SeatRangeRowCode & Right("0" & SeatRangeNumberFirst, 2)
If RequiredCrnt > 1 Then
Allocation = Allocation & "-" & SeatRangeRowCode & _
Right("0" & SeatRangeNumberFirst + RequiredCrnt - 1, 2)
End If
SeatRange = ""
ElseIf SeatRangeCount - RequiredCrnt < MinSeatsInRange Then
' Removing this requirement from this range
' would leave too small a remainder
If RowAvailPoss = 0 Then
' If no better means of fulfilling booking is found,
' this range will be accepted.
RowAvailPoss = RowAvailCrnt
End If
Else
' Range is more than big enough. Record seat range allocated to booking
' and calculate reduced range to be written back to "Available".
' Have leading zeroes because sort places "A1-A2" after "A11-A12" and
' "A1" after "A02-03"
Allocation = SeatRangeRowCode & Right("0" & SeatRangeNumberFirst, 2)
If RequiredCrnt > 1 Then
Allocation = Allocation & "-" & SeatRangeRowCode & _
Right("0" & SeatRangeNumberFirst + RequiredCrnt - 1, 2)
End If
SeatRange = SeatRangeRowCode & SeatRangeNumberFirst + RequiredCrnt
If SeatRangeNumberFirst + RequiredCrnt < SeatRangeNumberLast Then
SeatRange = SeatRange & "-" & SeatRangeRowCode & SeatRangeNumberLast
End If
End If
End If
If ErrorCrnt <> "" Then
Exit For
End If
If Allocation <> "" Then
' Required seats extracted from this range.
' Ignore remainder of Available column
Exit For
End If
Next ' RowAvailCrnt
End If ' ErrorCrnt = ""
If ErrorCrnt = "" Then
If Allocation = "" Then
If RowAvailPoss <> 0 Then
' A possible range was found but using it would have left an
' odd seat. Since nothing better has been found, use it
RowAvailCrnt = RowAvailPoss
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
' Fatal error. Should not be possible since range already decoded
Debug.Print ErrorCrnt
Worksheets("Allocated").Activate
Call MsgBox(ErrorCrnt, vbOKOnly)
Exit Sub
End If
' Know range is big enough so no need to check again
' Have leading zeroes because sort places "A1-A2" after "A11-A12" and
' "A1" after "A02-03"
Allocation = SeatRangeRowCode & Right("0" & SeatRangeNumberFirst, 2)
If RequiredCrnt > 1 Then
Allocation = Allocation & "-" & SeatRangeRowCode & _
SeatRangeNumberFirst + RequiredCrnt - 1
End If
SeatRange = SeatRangeRowCode & SeatRangeNumberFirst + RequiredCrnt
If SeatRangeNumberFirst + RequiredCrnt < SeatRangeNumberLast Then
SeatRange = SeatRange & "-" & SeatRangeRowCode & SeatRangeNumberLast
End If
Else
' No seat range big enough for RequiredCrnt was found
ErrorCrnt = "No range was found big enough to allow allocation of " & _
RequiredCrnt & " seats"
End If
End If
End If
End With
If ErrorCrnt = "" Then
' Find appropriate column in worksheet "Allocated"
With Worksheets("Allocated")
ColAllocCrnt = 1
Do While True
If .Cells(1, ColAllocCrnt).Value = DayCrnt Then
' Required column found
Exit Do
End If
' Step to set of columns for next day
ColAllocCrnt = ColAllocCrnt + WidthAllocGroup
If .Cells(1, ColAllocCrnt).Value = "" Then
' No matching column exists
'Debug.Assert False
ErrorCrnt = "No column in worksheet Allocated has heading """ & DayCrnt & """"
Exit Do
End If
Loop
End With
End If
If ErrorCrnt = "" Then
' No errors found. Perform all updates for this booking.
With Worksheets("Allocated")
RowAllocNext = .Cells(Rows.Count, ColAllocCrnt).End(xlUp).Row + 1
.Cells(RowAllocNext, ColAllocCrnt + OffsetAllocFamily).Value = FamilyNameCrnt
.Cells(RowAllocNext, ColAllocCrnt + OffsetAllocGiven).Value = GivenNameCrnt
.Cells(RowAllocNext, ColAllocCrnt + OffsetAllocSeats).Value = Allocation
End With
With Worksheets("Available")
If SeatRange = "" Then
' The range from which the allocate was made
' is now empty so delete it.
.Cells(RowAvailCrnt, ColAvailCrnt).Delete Shift:=xlUp
Else
' Range not cleared. Replaced old range with reduced range
.Cells(RowAvailCrnt, ColAvailCrnt).Value = SeatRange
End If
End With
With Worksheets("New bookings")
' Copy processed booking to worksheet Processed
.Range(.Cells(RowNewBkCrnt, ColNewBkFirst), .Cells(RowNewBkCrnt, ColNewBkLast)).Copy _
Destination:=Worksheets("Processed").Cells(RowProcNext, 1)
RowProcNext = RowProcNext + 1
' Delete processed booking
.Rows(RowNewBkCrnt).EntireRow.Delete
End With
' Note: No need to update RowNewBkCrnt because next row has moved up
Else
' A non-fatal error has occurred. Record it against the request.
With Worksheets("New bookings")
.Cells(RowNewBkCrnt, ColNewBkError).Value = ErrorCrnt
End With
RowNewBkCrnt = RowNewBkCrnt + 1 ' Update RowNextCrnt so this row is preserved
End If
Loop ' Until all new booking processed or abandoned
Application.ScreenUpdating = True
End Sub
有关此代码的说明，请参阅
这是第二次发帖。我在宏 Check.
Sub Check()
' Check there are no duplicate or missing seats.
' Report any errors found to the Immediate Window.
Dim ColAllocCrnt As Long
Dim ColAvailCrnt As Long
Dim ColSeatCrnt As Long
Dim DayCrnt As String
Dim ErrorCount As Long
Dim ErrorCrnt As String
Dim RowAllocCrnt As Long
Dim RowAllocLast As Long
Dim RowAvailCrnt As Long
Dim RowAvailLast As Long
Dim RowSeatCrnt As Long
Dim SeatNumberMax As Long
Dim SeatRecorded() As String
Dim SeatRecordedPart() As String
Dim SeatRowCodeMax As String
Dim SeatRowNumber As String
Dim SeatRange As String
Dim SeatRangeRowCode As String
Dim SeatRangeNumberFirst As Long
Dim SeatRangeNumberLast As Long
Dim SeatRangeCount As Long
' Loop for each day recorded in worksheet "Available"
ColAllocCrnt = 1
Do While True
With Worksheets("Allocated")
If .Cells(1, ColAllocCrnt).Value = "" Then
' All days analysed
Exit Do
End If
DayCrnt = .Cells(1, ColAllocCrnt).Value
End With
Debug.Print "Checking seats for " & DayCrnt
ErrorCount = 0
' It it not possible to increase the number of columns in an array so
' scan worksheets "Allocated" and "Available" for maximum row code
' and seat number.
SeatNumberMax = 0
SeatRowCodeMax = ""
With Worksheets("Allocated")
' ColAllocCrnt identifies the column for the current day
' Find maximum row code and seat letter in worksheet "Allocated"
' for current day
RowAllocLast = .Cells(Rows.Count, ColAllocCrnt).End(xlUp).Row
For RowAllocCrnt = RowAllocDataFirst To RowAllocLast
SeatRange = .Cells(RowAllocCrnt, ColAllocCrnt + OffsetAllocSeats).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
Debug.Print ErrorCrnt
ErrorCount = ErrorCount + 1
Else
If SeatNumberMax < SeatRangeNumberLast Then
' Record new highest seat number
SeatNumberMax = SeatRangeNumberLast
End If
If SeatRowCodeMax < SeatRangeRowCode Then
' Record new highest seat row code
SeatRowCodeMax = SeatRangeRowCode
End If
End If
Next
End With
With Worksheets("Available")
' There may be multiple columns in worksheet "Available" for the current day
ColAvailCrnt = 1
Do While True
If .Cells(1, ColAvailCrnt).Value = "" Then
' All columns in worksheet "Available" examined
Exit Do
End If
If Left(.Cells(1, ColAvailCrnt).Value, Len(DayCrnt)) = DayCrnt Then
' This column is for the current day
' Review SeatNumberMax and SeatRowCodeMax for available ranges
RowAvailLast = .Cells(Rows.Count, ColAvailCrnt).End(xlUp).Row
For RowAvailCrnt = RowAvailDataFirst To RowAvailLast
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
Debug.Print ErrorCrnt
ErrorCount = ErrorCount + 1
Else
If SeatNumberMax < SeatRangeNumberLast Then
' Record new highest seat number
SeatNumberMax = SeatRangeNumberLast
End If
If SeatRowCodeMax < SeatRangeRowCode Then
' Record new highest seat row code
SeatRowCodeMax = SeatRangeRowCode
End If
End If
Next
End If
ColAvailCrnt = ColAvailCrnt + 1
Loop
End With
Debug.Print " " & SeatRowCodeMax & SeatNumberMax
SeatRowNumber = Asc(SeatRowCodeMax) - Asc("A") + 1
' Size array so there is room for every possible seat
' Note: cells will be initialised to empty
ReDim RowSeatRecorded(1 To SeatNumberMax, 1 To SeatRowNumber)
' * Record workssheet, row and column on which each seat is recorded.
' Format is X:Row:Col where X is L for "Allocated" and V for "Available".
' * No seat should be recorded more than once. Report any duplicates.
With Worksheets("Allocated")
RowAllocLast = .Cells(Rows.Count, ColAllocCrnt).End(xlUp).Row
For RowAllocCrnt = RowAllocDataFirst To RowAllocLast
SeatRange = .Cells(RowAllocCrnt, ColAllocCrnt + OffsetAllocSeats).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAllocCrnt, ColAllocCrnt)
If ErrorCrnt <> "" Then
' Error already reported
Else
SeatRowNumber = Asc(SeatRangeRowCode) - Asc("A") + 1
For ColSeatCrnt = SeatRangeNumberFirst To SeatRangeNumberLast
If RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = 0 Then
' First occurrence of this seat number
RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = _
"L:" & RowAllocCrnt & ":" & ColAllocCrnt + OffsetAllocSeats
Else
' Duplicate recording of seat
Debug.Print " " & GenDuplicateSeatError(SeatRangeRowCode & ColSeatCrnt, _
RowSeatRecorded(ColSeatCrnt, SeatRowNumber), "L", _
RowAllocCrnt, ColAllocCrnt + OffsetAllocSeats)
ErrorCount = ErrorCount + 1
End If
Next
End If
Next
End With
With Worksheets("Available")
' There may be multiple columns in worksheet "Available" for the current day
ColAvailCrnt = 1
Do While True
If .Cells(1, ColAvailCrnt).Value = "" Then
' All columns in worksheet "Available" examined
Exit Do
End If
If Left(.Cells(1, ColAvailCrnt).Value, Len(DayCrnt)) = DayCrnt Then
' This column is for the current day
RowAvailLast = .Cells(Rows.Count, ColAvailCrnt).End(xlUp).Row
For RowAvailCrnt = RowAvailDataFirst To RowAvailLast
SeatRange = .Cells(RowAvailCrnt, ColAvailCrnt).Value
' Split seat range
Call DecodeSeatRange(SeatRange, SeatRangeRowCode, SeatRangeNumberFirst, _
SeatRangeNumberLast, SeatRangeCount, ErrorCrnt, _
RowAvailCrnt, ColAvailCrnt)
If ErrorCrnt <> "" Then
' Already reported
Else
SeatRowNumber = Asc(SeatRangeRowCode) - Asc("A") + 1
For ColSeatCrnt = SeatRangeNumberFirst To SeatRangeNumberLast
If RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = 0 Then
' First occurrence of this seat number
RowSeatRecorded(ColSeatCrnt, SeatRowNumber) = "V:" & RowAvailCrnt & ":" & ColAvailCrnt
Else
' Duplicate recording of seat
Debug.Print " " & GenDuplicateSeatError(SeatRangeRowCode & ColSeatCrnt, _
RowSeatRecorded(ColSeatCrnt, SeatRowNumber), "V", _
RowAvailCrnt, ColAvailCrnt)
ErrorCount = ErrorCount + 1
End If
Next
End If
Next
End If
ColAvailCrnt = ColAvailCrnt + 1
Loop
End With
' Look for gaps in the array of seats.
For RowSeatCrnt = 1 To UBound(RowSeatRecorded, 2)
' Scan for recorded seat
For ColSeatCrnt = UBound(RowSeatRecorded, 1) To 1 Step -1
If RowSeatRecorded(ColSeatCrnt, RowSeatCrnt) <> "" Then
' This seat recorded
Exit For
End If
Next
' Scan for gap between last recorded seat and first
For ColSeatCrnt = ColSeatCrnt - 1 To 1 Step -1
If RowSeatRecorded(ColSeatCrnt, RowSeatCrnt) = "" Then
Debug.Print " Seat " & Chr(RowSeatCrnt + 64) & ColSeatCrnt & " not found"
ErrorCount = ErrorCount + 1
End If
Next
Next
Debug.Print " " & ErrorCount & " errors found"
ColAllocCrnt = ColAllocCrnt + WidthAllocGroup
Loop ' For each day in worksheet "Allocated
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function
Sub DecodeSeatRange(ByVal SeatRange As String, ByRef RowCode As String, _
ByRef NumberFirst As Long, ByRef NumberLast As Long, _
ByRef Count As Long, ByRef ErrorMsg As String, _
ByVal RowAvail As Long, ByVal ColAvail As Long)
' * Split a seat range into it components.
' * A seat range is:
' RowCode Number
' or RowCode Number - RowCode Number
' * The two RowCodes must be the same.
' * The numbers must be one or more and Last cannot be less than First
' * If ErrorMsg = "" or return, the seat range has been successfully
' decoded. Otherwise it reports the error found.
Dim RangePart() As String
RangePart = Split(SeatRange, "-")
If UBound(RangePart) = 0 Then
' Have single seat range.
' Extract seat details into variables and perform internal checks
RowCode = Mid(SeatRange, 1, 1)
If IsNumeric(Mid(SeatRange, 2)) Then
NumberFirst = Mid(SeatRange, 2)
NumberLast = NumberFirst
Count = 1
Else
ErrorMsg = "Seat number is not numeric"
End If
Else
' Have normal seat range; Xn-Ym.
' Split range details into variables and perform internal checks
RowCode = Mid(RangePart(0), 1, 1)
If RowCode <> Mid(RangePart(1), 1, 1) Then
ErrorMsg = "Fatal error in worksheet ""Available"". Range in cell " & _
ColNumToCode(ColAvail) & RowAvail & " is not a single row"
Else
If Not IsNumeric(Mid(RangePart(0), 2)) Then
ErrorMsg = "Fatal error in worksheet Available. Start of range in cell " & _
ColNumToCode(ColAvail) & RowAvail & _
" is not <RowCode><Number>"
Else
NumberFirst = Mid(RangePart(0), 2)
If Not IsNumeric(Mid(RangePart(1), 2)) Then
ErrorMsg = "Fatal error in worksheet Available. End of range in cell " & _
ColNumToCode(ColAvail) & RowAvail & _
" is not <RowCode><Number>"
Else
NumberLast = Mid(RangePart(1), 2)
Count = NumberLast - NumberFirst + 1
If Count > 0 Then
' Good range
Else
' Bad range
ErrorMsg = "Fatal error in worksheet Available. " & _
"Start of range after end of range cell " & _
ColNumToCode(ColAvail) & RowAvail
End If
End If
End If
End If
End If ' single seat/multiple seat range
End Sub
Function GenDuplicateSeatError(ByVal Seat As String, ByVal Record As String, _
ByVal WshtCode As String, ByVal RowCrnt As Long, _
ByVal ColCrnt As Long) As String
' * Record contained details of a previous encounter of a seat. Its format is
' X:Row:Column where X is "L" for worksheet "Allocated" or "V" for worksheet
' "Available".
' * WshtCode, RowCrnt and ColCrnt identify a second or subsequent encounter
' of the seat. Generate a suitable error message.
Dim RecordPart() As String
RecordPart = Split(Record, ":")
GenDuplicateSeatError = "Seat " & Seat & " is recorded in " & _
IIf(RecordPart(0) = "L", "Allocated", "Available") & "." & _
ColNumToCode(Val(RecordPart(2))) & RecordPart(1) & " and " & _
IIf(WshtCode = "L", "Allocated", "Available") & "." & _
ColNumToCode(ColCrnt) & RowCrnt
End Function