Excel VBA今日の作業者のスケジュールから名前を集める

Question

これはよくある質問だと思っていましたが、私は検索して答えを見つけることができませんでした。

私は仕事のスケジュールがあり、今日の日付を検索し、今日仕事を予定している人の名前をすべて返したいと思います。私は動作するコードを作成しましたが、完了するまでに時間がかかり、実行するたびに100％有効ではありません。私はこれを行うためのより速く、より速い方法がなければならないと確信していますが、私はまだそれを見つけることができませんでした。私はそれを2つの異なるコードに分解しています。最初の人は今日の日付がある列を見つけ、2番目の人は名前を集めて次のシートに配置します。

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 

及び第2サブ：

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 

が再び、あなたの助けを大幅に高く評価され

は、ここで第一副です！

Answer 1

実行時間が長すぎると、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 

Answer 2

あなたの最初のサブは、あなたの第2のサブでの変数に割り当てることができる値を返す、実際には、関数である（またはでなければなりません）。次のコードはその概念を実現しています。それは他の点でも違いますが、私はあなたがそれを好きになると思います。してみてください。私の以前のコメントを無視

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