即使我认为这是一个常见的问题，但我已经搜索过，似乎无法找到答案。
我有工作时间表，我想搜索今天的日期，并返回计划今天工作的所有人的姓名。我构建了一个可以运行的代码但是它需要很长时间才能完成，并且每次运行都不是100％有效。我相信必须有一个更好，更快的方法，但我还没有找到一个。我把它拆分成两个不同的代码。第一个找到今天日期所在的列，第二个收集名称并将它们放在下一张纸上。
这是First Sub：
Sub GetDateRow_()
'//////Finds the row that has today's date and returns the value of that row to cell C34\\\\\\
Dim SearchMe As Integer
SearchMe = Sheets("Sheet1").Range("C33")
Set FindMe = Sheets("Sheet1").Range("C5:AD5").Find(What:=SearchMe, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Sheets("Sheet1").Range("C34").Value = Cells(1, FindMe.Column)
End Sub
和第二个子：
Sub CopyScheduledToList()
'//////Searches Today's day Column from the schedule given by GetDateRow Sub & assimbles \\\\\\\
'////// the names of those who are scheduled to work today to a list on Page 2 \\\\\\\
Dim Ccount As Integer
Dim lngLoop As Long
Dim RowCount As Integer
Dim dShift As String
Dim cShift As String
Ccount = 1
dShift = "A63"
cShift = "TLA"
RowCount = Sheets("Sheet1").Range("C34").Value
lngLoop = 1
For lngLoop = 1 To Rows.count
If Cells(lngLoop, RowCount).Value = cShift Then Worksheets("Sheet2").Cells(1, 4).Value = Worksheets("Sheet1").Cells(lngLoop, 1).Value
'////// Get's the Team Leader and places name into column D on Page 2
If Cells(lngLoop, RowCount).Value = dShift Then Worksheets("Sheet2").Cells(Ccount, 1).Value = Worksheets("Sheet1").Cells(lngLoop, 1).Value
If Worksheets("Sheet2").Range("A" & Ccount).Value <> "" Then Ccount = Ccount + 1
'////// Places the name from the working list onto page 2 and adds a count so the next value found
'////// will go to the next empty row on Sheet 2
Next lngLoop
End Sub
再次，非常感谢您的帮助！
答案 0 :(得分：0)
您的运行时间过长将归因于For lngLoop = 1 To Rows.count循环中的1048576个单元格的循环。只需处理包含适用列中数据的最后一个单元格即可改善这一点。
它并不总是正常工作的问题几乎可以肯定是因为您有一些Cells个参考资料，这些参考资料不符合您要使用的工作表，因此它们指的是ActiveSheet。
Sub GetDateRow_()
'//////Finds the row that has today's date and returns the value of that row to cell C34\\\\\\
Dim SearchMe As Date
Dim FindMe As Range
With Worksheets("Sheet1")
SearchMe = .Range("C33").Value
Set FindMe = .Range("C5:AD5").Find(What:=SearchMe, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If FindMe Is Nothing Then
MsgBox "Date not found!"
Else
'I think this line
'.Range("C34").Value = .Cells(1, FindMe.Column).Value
'should be
.Range("C34").Value = FindMe.Column
'so that it saves the column number you want
End If
End With
End Sub
Sub CopyScheduledToList()
'//////Searches Today's day Column from the schedule given by GetDateRow Sub & assembles \\\\\\\
'////// the names of those who are scheduled to work today to a list on Page 2 \\\\\\\
Dim Ccount As Integer
Dim lngLoop As Long
Dim TodaysCol As Long
Dim dShift As String
Dim cShift As String
Dim lastRow As Long
Dim wsSrc As Worksheet
Dim wsDst As Worksheet
Ccount = 1
dShift = "A63"
cShift = "TLA"
Set wsSrc = Worksheets("Sheet1")
Set wsDst = Worksheets("Sheet2")
TodaysCol = wsSrc.Range("C34").Value
'Find last used row in today's column
lastRow = wsSrc.Cells(wsSrc.Rows.Count, TodaysCol).End(xlUp).Row
For lngLoop = 1 To lastRow
If wsSrc.Cells(lngLoop, TodaysCol).Value = cShift Then
wsDst.Cells(1, "D").Value = wsSrc.Cells(lngLoop, "A").Value
End If
'////// Get's the Team Leader and places name into column D on Page 2
If wsSrc.Cells(lngLoop, TodaysCol).Value = dShift Then
If wsSrc.Cells(lngLoop, "A").Value <> "" Then
wsDst.Cells(Ccount, "A").Value = wsSrc.Cells(lngLoop, "A").Value
Ccount = Ccount + 1
End If
End If
'////// Places the name from the working list onto page 2 and adds a count so the next value found
'////// will go to the next empty row on Sheet 2
Next lngLoop
End Sub
答案 1 :(得分：0)
实际上，您的第一个子函数是一个函数（或应该是函数），它返回一个值，该值可以分配给第二个子函数中的变量。以下代码实现了这一概念。它在其他方面也有所不同，但我认为你会喜欢它。请试试。
Option Explicit
Sub CopyScheduledToList()
'//////Searches Today's day Column from the schedule given by GetDateRow Sub & assambles \\\\\\\
'////// the names of those who are scheduled to work today to a list on Page 2 \\\\\\\
' it is best practise, not to have any hard-coded addresses in the code.
' Therefore it is good to place all parameters separate from and before the code:
Const SearchRow As Long = 5
Const dShift As String = "A63"
Const cShift As String = "TLA"
Dim WsMain As Worksheet ' better to set your own variable
Dim WsOutput As Worksheet ' even if it will be "ActiveSheet"
Dim TgtColumn As Long
Dim Rlast As Long ' last data row in WsMain
Dim Rcount As Long ' output row counter
Dim R As Long
Set WsMain = ActiveSheet ' might be Sheets("Sheet1")
Set WsOutput = Worksheets("Sheet2") ' or, simply, Sheet1
TgtColumn = DateColumn(WsMain, SearchRow)
If TgtColumn < 1 Then Exit Sub
Rcount = 1
With WsMain
Rlast = .Cells(.Rows.Count, TgtColumn).End(xlUp).Row
For R = 1 To Rlast
Select Case .Cells(R, TgtColumn).value
Case cShift
'////// Get's the Team Leader and places name into column D on WsOutput
WsOutput.Cells(Rcount, "D").value = .Cells(R, 1).value
Case dShift
WsOutput.Cells(Rcount, "A").value = .Cells(R, 1).value
Case Else
Exit Sub ' define the correct response if neither is found
End Select
If Len(WsOutput.Cells(Rcount, "A").value) Then Rcount = Rcount + 1
'////// Places the name from the working list onto page 2 and adds a count so the next value found
'////// will go to the next empty row on Sheet 2
Next R
End With
End Sub
Private Function DateColumn(Ws As Worksheet, _
ByVal SearchRow As Long) As Long
' returns the row that has today's date
' return 0 if not found
Dim SearchMe As Variant
Dim TgtDate As String
Dim Fnd As Range
If SearchRow < 1 Then Exit Function
Do
TgtDate = InputBox("Enter the target date", _
"List shift workers", _
Format(Date, "Short Date"))
' you can also set the default like Format(Date + 1, "d/m/yy")
' the sample date format must match your regional settings
If IsDate(TgtDate) Then
SearchMe = CDate(TgtDate)
' SearchMe will have the date in the format set
' in your regional settings
Exit Do
Else
MsgBox "Please enter a valid date" & vbCr & _
"in d-m-yy format", vbExclamation, "Invalid date"
' adjust the required format to your regional settings
End If
Loop While Len(TgtDate) ' enter blank or press Cancel to exit
Set Fnd = Ws.Rows(SearchRow).Find(What:=SearchMe, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not Fnd Is Nothing Then DateColumn = Fnd.Column
End Function