座位预订工作簿
我正在尝试为我在大学管理的节目创建座位预订电子表格。我列出了每个座位一排的所有座位以及每个客户要求的座位数量列表。
有没有什么方法可以让我找到一个空座位块的宏，并粘贴一个客户的名字，该客户想要在座位中的每个单元格中有多个座位？
3 个答案:
答案 0 :(得分：0)
我需要一些测试数据，所以我设想了这样的礼堂：
我的中间有一个坚固的挡块，侧面扇出翅膀。在后面我有轮椅使用者的空间。我不记得曾经看过一个剧院或礼堂，每个楼层都不是这个主题的变体。我也不记得座位编号系统不是＆lt; floor＆gt;＆lt; letter＆gt;＆lt; number＆gt;。我没有处理多个楼层。我希望这与你的礼堂足够接近，让你对自己说：“是的：我可以根据自己的需要调整它。”
听起来好像你今天需要这个系统。我记得有一幅漫画：“我当然需要它。如果我明天需要它，我明天就会要求它。“所以我想要简单而不是优雅。
我被告知，良好计划的秘诀是一个很好的数据模型。在我看来，每行一个座位不是一个好的数据模型。我想我可以使它工作，但代码将是复杂和令人困惑的。我的数据模型将从范围开始：A3-A13，B3-B13，C4-C14等。我发现输入所有这些范围很困难;我一直糊涂了。所以我切换到一个未使用的工作表并键入前两列并使用公式创建第三列：
我将在片刻解释奇怪的序列。你可能比我更好地键入范围，因此不需要这个中间步骤。
然后我将值从第3列复制到工作表“可用”以创建：
我已将周四至周四的四天命名为。您可以使用任何四个字符串，只要它们不同即可。我将座位分为两种类型：“常规”和“轮椅使用者”。前面的行可以有一个价格，后面的行可以有一个价格，或者任何其他可能合适的分区。每个部门每天需要一列，每个部门需要一个名称。必须有单独的列，因为每个部门的席位是独立分配的。
我答应解释这个奇怪的序列。除了一个例外（如下所述），第一行中的所有座位将在第二行中的任何座位之前分配。在我开始使用机翼座椅之前，我已经决定要填充中间部分的前四行。由于系统从顶部开始并向下运行，因此您可以控制分配范围的顺序。您可能不需要该功能，但如果您这样做则可以免费使用。
在考虑B3-B13之前填充A3-A13的例外是因为你不想在行的末尾填充奇数座位。我假设大多数预订适用于单人，三人等场合的情侣。如果预订意味着A12将被填补但不是A13，则该预订将被分配给B3-B13区块。除非没有更好的选择，否则A3-A13区块的最终席位将只会填写与剩余席位相匹配的预订。
你说你有“一个列表，说明每个客户要求的座位数。”我已经生成了一些随机预订：
如果您当前的列表已合并给定和姓氏，我们将遇到拆分问题，因为我真的相信我们需要将它们分开。 “日”和“部分”对应于工作表“可用”中的列标题。通过组合这些值，系统知道哪个列适合此预订。大多数测试预订都是两个座位，分别是三个，四个四分之一。一次预订是十四个座位，系统将无法处理。根据我的经验，大型团体在相邻行中获得匹配的座位（例如：A3-A9和B3-B9）。您必须手动处理此类请求。
宏Allocate可以根据需要经常运行。您在工作表“新预订”中键入一些预订并运行宏。宏检查列表中的每个预订，为其分配座位，从工作表“可用”中删除分配的席位，将分配的详细信息添加到工作表“已分配”，并将处理后的预订移至工作表已处理。通常情况下，我会在数组中处理所有这些，但我认为如果它在工作表上运行，编码和理解会更容易。针对我的可用运行测试数据的结果是：
只有无法处理的预订仍保留在工作表“新预订”中。无法处理预订的原因已被添加。
请注意，行A，B等已从Available中消失，因为它们已被分配。
工作表“已分配”是您需要的任何报告的来源。您可以按名称或座位排序以获得不同的列表。你可以打印票。你可以按照你在问题中的建议建立一个“礼堂”预订视图。
两个宏Allocate和Check分别在答案中，因为我已超出答案的字符数限制。
Allocate执行上述分配过程。
Check验证工作表“可用”和“已分配”。 Allocate更新必须保持一步的四个工作簿。一个模糊的错误可能意味着座位被分配两次或从系统中丢失。我已经彻底测试了Allocate，但我无法保证它没有错误。通过运行Check，您将能够立即检测到任何错误的影响。
我建议你仔细测试Allocate。在宏未使用的工作表中保留预订副本和可用席位。
如果您遇到错误，您可能需要向我发送您的数据副本。查看我的个人资料以获取电子邮件地址。
上面的图片显示了宏使用的四个工作表。它们也在宏中完全解释。你的帖子是我早上1点或凌晨2点所以我猜你是在美国西海岸。不幸的是，这只是为了最大化我们沟通的转折时间。
祝你好运。
答案 1 :(得分：0)
有关此代码的说明，请参阅Main answer。
这是第二次发布。我对宏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
答案 2 :(得分：0)
有关此代码的说明，请参阅Main answer。
这是第二次发布。我已经为宏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
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？