我有一个电子表格，其中包含一张名为＆＃39; Classes＆＃39;这包含每节课的开始（L）和结束时间（K）以及参加本课程的持续时间（J），课程代码（A）和学生姓名（B）。
我必须按照这个时间表计划额外的课程，但学生最多只能有5个小时不间断。虽然我的时间表，其他人也正在改变我工作的时间表，所以每天我都需要能够检查是否有任何课程已经移动给学生连续几个小时。
我能想到这样做的唯一方法是某种循环，它会将学生姓名和开始时间相结合，然后将其与学生和结束时间的连续进行比较。当找到匹配时，它会将持续时间加在一起。我需要它来返回学生和他们有太多时间的那一天。我不知道如何在VBA栏中实现这一点我的建议。有什么想法吗？
答案 0 :(得分：0)
抱歉，此答案中没有图片。自我上次发布答案以来引入的图像新系统崩溃或崩溃了我的浏览器。我明天再试一次。我再次尝试没有成功。我已经报告了这个问题，但怀疑我会在周一之前听到任何消息。也许答案可以在没有图像的情况下使用。或者，我的个人资料包含一个电子邮件地址，您可以根据需要索取图像副本。
如果你要去Google做任何事情，请把它变成“Excel VBA教程”。如果您在不了解VBA基础知识的情况下搜索代码以实现某些目标，则在找到代码时将无法识别代码。我们在这里得到的问题是，发布的代码几乎就是提问者想要的，但是他们缺少VBA来进行微不足道的改变。
如果您搜索“Excel VBA教程”，您会发现许多可供选择。尝试一下，然后完成符合您学习风格的一个。我更喜欢书。我参观了一个很好的图书馆并借用了最有前途的Excel VBA Primers在家里试用。然后我买了一个我最喜欢的作为永久参考。十二年后，我仍然一次又一次地检查它。你花在学习基础知识上的时间会迅速回报。
一旦了解了基础知识，就可以开始设计宏了。我创建了一些符合您描述的演示数据：
原始数据
我添加了一个Day列，因为您说工作表包含一周内发生的所有类。我已经把大部分课程都做了一个小时，并允许五分钟的旅行时间从一个班级到另一个班级。我不在乎这些数据是不是很现实;我只是想要一些模糊的东西作为测试数据和讨论辅助。
要为学生找到连续的课程，您需要将数据放在学生日开始序列中。我已经输入了作为Mon，Tue等的“day”，这对于人类用户来说是方便的，但意味着当“Fri”排序时将出现在“Mon”之前。宏独立地对待每一天，因此不关心天的顺序。如果在周一的课程之前报告星期五课程的异常情况，那可能无关紧要。我稍后会再次讨论这个问题。
在任何编码之前完成设计可能会更好。但是，如果早期阶段很明显，通常更容易对它们进行编码，这样您就可以在设计后期阶段时看到数据。
获取排序代码的最简单方法是使用宏录制器。宏记录器不用于循环或if-then-else-endif，但是当你不知道语句的语法时很方便。
我激活了工作表“Classes”，然后打开了宏录制器。 （工具 - ＆gt;宏 - ＆gt;记录新宏）。我选择了所有单元格然后“数据 - ＆gt;排序“然后指定我想要的列。排序后，我关闭了宏录制器。保存的代码是：
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 10/09/2015 by Tony Dallimore
'
Cells.Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("G2") _
, Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
End Sub
这是语法上正确的VBA，但它不是很好的VBA。宏录像机不知道你的目标;它只是单独记录每个语句。但是，整理这个并不困难：
With Worksheets("Classes")
.Cells.Sort Key1:=.Range("B2"), Order1:=xlAscending, Key2:=.Range("G2") _
, Order2:=xlAscending, Key3:=.Range("L2"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
End With
以上是最小的整洁。我添加了With语句来标识目标工作表;我已移除Select，并在Cells和Range前面放置一段时间，表明它们受With声明的约束。如果你不知道我在说什么，别担心;一旦完成了教程，你就会。
我通常会整理参数，但我会将其作为练习留给你。我还要做的是用名字替换列字母。如果您在代码中隐藏列字母或数字，则在添加新列或重新排序现有列时会遇到实际问题。我会用以下之一替换上面的内容：
Const ColClsStud As String = "B"
Const ColClsDay As String = "G"
Const ColClsStart As String = "L"
With Worksheets("Classes")
.Cells.Sort Key1:=.Range(ColClsStud & "2"), Order1:=xlAscending, _
Key2:=.Range(ColClsDay & "2"), Order2:=xlAscending, _
Key3:=.Range(ColClsStart & "2"), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
End With
或者，我的偏好：
Const ColClsStud As Long = 2
Const ColClsDay As Long = 7
Const ColClsStart As Long = 12
With Worksheets("Classes")
.Cells.Sort Key1:=.Cells(2, ColClsStud), Order1:=xlAscending, _
Key2:=.Cells(2, ColClsDay), Order2:=xlAscending, _
Key3:=.Cells(2, ColClsStart), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
End With
Const（常量）语句意味着，如果列移动，则一次更改会修复宏。我的名字都遵循一种模式：一串缩写。例如，ColClsStud是列级学生。
我们现在可以看到排序数据：
排序数据
我只在星期一和星期五创建了数据，但我相信这个答案已足够了。如前所述，“星期五”出现在“星期一”之前。这可能无关紧要，因为必须单独考虑一周中的每一天。如果它是不可接受的，最简单的解决方案是将=FIND(G2,"MonTueWedThuFri")写入第2行的未使用列并向下复制。这将给出数字（Mon-> 1，Tue-> 4，Wed-> 7，Thu-> 10，Fri-> 13），其可以用于排序而不是Day。如果这还不够，可以使用更优雅的解决方案，尤其是VBA。
根据这个序列中的数据，很容易看出人类如何能够识别超过五小时的块并确定有用的间隙。宏可以使用类似的技术。宏如何“报告”过多的块和有用的差距？我在另一个工作表中考虑了报告，但认为这很尴尬，因为在尝试修复问题时你必须在两个工作表之间切换。我决定采用一种好方法：
标记数据
这里我有五个多小时的彩色积木。红色可能是更传统的颜色，但我发现浅黄色更加宁静。有些网站列出了所有Excel的颜色以及如何获取它们，因此如果您不喜欢我的选择，您可以切换到另一种颜色。我已插入部分空行以报告可能有用的间隙。如果您需要使用间隙，则可以准备一行，只需要尽可能少的更新。
下面的宏包括要定义的常量：日期开始，日期结束，间隙大小等。
在您的数据上试用我的宏。逐步完成并研究它如何识别大块和间隙。您是否同意所使用的技术类似于人类可能使用的技术？
宏包含描述每个代码块用途的注释，但对用于实现这些目的的语句几乎没有说明。一旦你知道一个语句存在，通常很容易查找它。我相信除了函数DateAdd和DateDiff之外，这个宏中没有任何东西你不需要开始教程。一旦你知道他们的名字，你很容易查找功能。或者，您可以搜索“Excel VBA日期和时间函数”。
尽可能回答问题，但是，你越发现自己越快，你的发展就越快。
我认为学习编程就像学习驾驶汽车一样。在第一课结束时，你知道你永远不能转动一个轮子，移动一个变速杆，按下三个踏板中的一个或两个，看三个镜子并同时操作指示器。但是一个月后，你想知道你发现了什么这么困难。
Option Explicit
Const ColClsCode As Long = 1
Const ColClsStud As Long = 2
Const ColClsDay As Long = 7
Const ColClsDuration As Long = 10
Const ColClsEnd As Long = 11
Const ColClsStart As Long = 12
Const ColClsLast As Long = 12 ' Used for colouring problem rows
Const ClrTooLong As Long = &H99FFFF ' Light yellow = RGB(255,255,153)
Const ContinuousMaximum As Long = 300 ' In minutes
' I assume there is a minimum gap between classes to count as a break.
Const GapBreakMinimum As Long = 20 ' In minutes
' I assume the is a minimum duration for a class. Gaps smaller than that
' minimum would not be useful,
Const GapUsefulMinimum As Long = 30 ' In minutes
' I assume there is a start and end time for the academic day
Const TimeDayStart As Date = #9:00:00 AM#
Const TimeDayEnd As Date = #3:30:00 PM#
Sub IdentifyProblemsAndGaps()
' Within worksheet Classes:
' * Colour any sequence of lessons for a student that exceeds the maximum.
' * Insert rows for any gaps that are large enough to be filled with a new lesson.
Dim DayCrnt As String
Dim RowClsCodeLast As Long
Dim RowClsStudCrntFirst As Long
Dim RowClsStudLast As Long
Dim RowClsCrnt As Long
Dim StudentCrnt As String
Dim TimeBlockEnd As Date
Dim TimeBlockStart As Date
' Application.ScreenUpdating = False ' This speeds the macro but makes debugging more difficult
With Worksheets("Classes")
' Remove any colouring remaining from last run of macro.
.Cells.Interior.ColorIndex = xlNone
' Sort rows on class code so rows with a blank class code are at the bottom
.Cells.Sort Key1:=.Cells(2, ColClsCode), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Find last used rows in class code and student columns
RowClsCodeLast = .Cells(Rows.Count, ColClsCode).End(xlUp).Row
RowClsStudLast = .Cells(Rows.Count, ColClsStud).End(xlUp).Row
If RowClsStudLast > RowClsCodeLast Then
' There is at least one row with a student name but no class code
' Assume rows without a class code are to report gaps. Such rows
' must be deleted
.Rows(RowClsCodeLast + 1 & ":" & RowClsStudLast).Delete
End If
' Sort into Student, Day, Start tiem sequence
.Cells.Sort Key1:=.Cells(2, ColClsStud), Order1:=xlAscending, _
Key2:=.Cells(2, ColClsDay), Order2:=xlAscending, _
Key3:=.Cells(2, ColClsStart), Order3:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
RowClsCrnt = 2 ' First data row. Assume one header row.
TimeBlockStart = 0 ' I assume no lesson can start at midnight
TimeBlockEnd = 0
StudentCrnt = "" ' No current student
DayCrnt = "" ' No current day
' The end value for a For-Loop cannot change during a loop. This code inserts
' rows so the end value will change. I have used a Do-Loop instead.
Do While True
' When I code a routine, I create test data that covers every scenerio I can
' think of and I code for every scenerio I can think of. I then place
' "Debug.Assert False" at the top of every path through the code. As I
' test the code, I comment out each "Debug.Assert False" reached. If any are
' left at the end of testing, it implies my test data is inadequate or my
' code has a logic error. Either way, it demonstrates that more testing and
' debugging is required
'Debug.Assert False
If StudentCrnt = .Cells(RowClsCrnt, ColClsStud).Value And _
DayCrnt = .Cells(RowClsCrnt, ColClsDay).Value Then
' Another row for the same student day
'Debug.Assert False
If DateAdd("n", GapBreakMinimum, TimeBlockEnd) > .Cells(RowClsCrnt, ColClsStart).Value Then
' Current row is part of current block
' Extend current block to include it
'Debug.Assert False
TimeBlockEnd = .Cells(RowClsCrnt, ColClsEnd).Value
Else
' Have gap within day
'Check if block just ended is too long; report if it is.
'Debug.Assert False
Call ReviewBlockJustEndColourIfAppropriate(RowClsStudCrntFirst, RowClsCrnt - 1, _
TimeBlockStart, TimeBlockEnd)
' Check if gap is useful; report if it is.
Call ReviewGapFillIfAppropriate(RowClsCrnt, TimeBlockEnd, _
.Cells(RowClsCrnt, ColClsStart).Value, _
StudentCrnt, DayCrnt)
' Start new block
TimeBlockStart = .Cells(RowClsCrnt, ColClsStart).Value
TimeBlockEnd = .Cells(RowClsCrnt, ColClsEnd).Value
RowClsStudCrntFirst = RowClsCrnt
End If
Else
' New student or new day or first row
If StudentCrnt <> "" Then
'Check if block just ended is too long; report if it is.
'Debug.Assert False
Call ReviewBlockJustEndColourIfAppropriate(RowClsStudCrntFirst, RowClsCrnt - 1, _
TimeBlockStart, TimeBlockEnd)
' Check if gap between last class and end of day is useful; report if it is.
Call ReviewGapFillIfAppropriate(RowClsCrnt, TimeBlockEnd, _
TimeDayEnd, _
StudentCrnt, DayCrnt)
End If
' Start new block
StudentCrnt = .Cells(RowClsCrnt, ColClsStud).Value
If StudentCrnt = "" Then
' End of data
Exit Do
End If
DayCrnt = .Cells(RowClsCrnt, ColClsDay).Value
TimeBlockStart = .Cells(RowClsCrnt, ColClsStart).Value
TimeBlockEnd = .Cells(RowClsCrnt, ColClsEnd).Value
RowClsStudCrntFirst = RowClsCrnt
' Check if gap between start of day and first class is useful; report if it is.
Call ReviewGapFillIfAppropriate(RowClsCrnt, TimeDayStart, _
TimeBlockStart, _
StudentCrnt, DayCrnt)
End If
RowClsCrnt = RowClsCrnt + 1
Loop ' For each data row in Classes
End With
Application.ScreenUpdating = False
End Sub
Sub ReviewBlockJustEndColourIfAppropriate(ByVal RowBlockStart As Long, ByVal RowBlockEnd As Long, _
ByVal TimeBlockStart As Date, ByVal TimeBlockEnd As Date)
' A continuation block of classes for a student has ended.
' Determine is the duration of those classes exceeds the maximum
' Colour classes if their duration exceeds the maximum
Dim Duration As Long
Duration = DateDiff("n", TimeBlockStart, TimeBlockEnd) ' Duration in minutes
If Duration > ContinuousMaximum Then
'Debug.Assert False
With Worksheets("Classes")
.Range(.Cells(RowBlockStart, 1), _
.Cells(RowBlockEnd, ColClsLast)).Interior.Color = ClrTooLong
End With
End If
End Sub
Sub ReviewGapFillIfAppropriate(ByRef RowClsCrnt As Long, _
ByVal TimeGapStart As Date, ByVal TimeGapEnd As Date, _
ByVal StudentCrnt As String, ByVal DayCrnt As String)
' There may be a gap above the current row.
' Determine if there is a gap and if it is big enough to be useful.
' If there is a useful gap, insert a row reporting the gap.
Dim Duration As Long
Duration = DateDiff("n", TimeGapStart, TimeGapEnd) ' Duration in minutes
If Duration >= GapUsefulMinimum Then
' Have a useful gap. Insert row
'Debug.Assert False
With Worksheets("Classes")
.Rows(RowClsCrnt).Insert
.Rows(RowClsCrnt).Interior.ColorIndex = xlNone ' Ensure colour nor copied from previous row
.Cells(RowClsCrnt, ColClsStud).Value = StudentCrnt
.Cells(RowClsCrnt, ColClsDay).Value = DayCrnt
.Cells(RowClsCrnt, ColClsDuration).Value = Duration
End With
RowClsCrnt = RowClsCrnt + 1 ' Advance to what was current row
End If
End Sub