Excel VBA从今天工作的人们收集姓名
即使我认为这是一个普遍的问题，我已经search，似乎无法find答案。
我有一个工作时间表，我想search今天的date，并返回所有计划今天工作的人的名字。 我build立了一个可行的代码，但需要很长时间才能完成，并且每次运行都不是100％有效。 我相信肯定有一个更好更快的方法来做到这一点，但我还没有find一个。 我把它分解成两个不同的代码。 第一个find今天的date所在的列，第二个收集名称，并将它们放在下一张表。
这是第一个小组：
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
再次感谢您的帮助！
您的运行时间过长将会导致在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
你的第一个子实际上是一个函数（或者应该是），它返回一个可以赋值给第二个子variables的值。 下面的代码实现了这个概念。 在其他方面也有所不同，但我想你会喜欢的。 请尝试。
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 dm-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