在另一列中複製基於日期的值範圍

Question

我正在嘗試編寫一個宏，它可以根據另一列中的相應日期在一列中複製一個範圍的值。

例如，我需要複製G列中與B列日期對應的值。對於2015年9月18日，我需要根據日期9/18/2015年的B列。然後我需要爲9/19做相同的事情，其他日期如此。然後我將它粘貼到其他幾頁，儘管這部分代碼並未包含在這裏。

我下面的嘗試只檢查列B中的日期，然後複製列G中的範圍。我相信我需要一個for循環，但我不知道如何正確構建它以滿足需要。

If ActiveCell >= Date + 1 And ActiveCell <= Date + 7 Then 

' Compare date on Day Sheet to sheet s and select cells in column G 
' corresponding to that date 

     x = ActiveCell 
     ActiveWorkbook.Sheets("s").Activate 
     Range("B2").Select 

' If statement to check if dates match 

      If ActiveCell = x Then 
      Range("G2").Select 
      ActiveCell.Offset(0, 5).Select 
      Range("G2:G10").Copy 
      Else 
      End If 

Answer 1

哦，這太詭異了。我現在有一個幾乎相同的任務 - 除了我的每月從SQL導入到Excel的航班日誌，必須將每日的時間轉移到飛行員的個人工作表。將「賬戶」切換爲「試點」和「金額」爲「飛行時間」，我們的項目完全相同。

我幾乎只是剪下和粘貼下面的代碼，它會爲你做整個shabang。在StackOverflow上解決某個人的整個任務並不是很好的形式，但在這種情況下，只是粘貼一些程序似乎毫無意義。

對我來說，最大的教訓就是把Excel當作數據檢索和數據顯示界面。訣竅是創建自己的數據結構，將數據讀入它們，根據需要操作/詢問它們，然後在完成所有工作時將結果寫入工作表。換句話說，避免像鼠疫這樣的宏觀生成器！我寧願懷疑你的拷貝單元格x，y粘貼到單元格r，c的方法會把你帶到我上升的同樣的死角。我發現的最好的方法是有一個Dictionary飛行員（帳戶爲你），然後內部Dictionary的航班日期（價值/日期爲你）。然後，您只需測試一天賬單中每個賬戶的賬戶密鑰和日期密鑰。

要訪問Dictionary對象，您需要引用Microsoft Scripting Runtime（工具 - >引用... - >通過勾選複選框在列表中進行選擇）。

您需要創建兩個類 - 這些是您的數據字段。調用第一cAccountFields和下面的代碼添加到類：

Public AccountName As String 
Public ActivityByDate As Dictionary 
Public Sub Create(accName As String) 
    Me.AccountName = accName 
    Set Me.ActivityByDate = New Dictionary 
End Sub 

呼叫第二cActivityFields和下面的代碼添加到類：

Public DateOf As Date 
Public Value As Double 
Public Sub Create(dat As Date, val As Double) 
    Me.DateOf = dat 
    Me.Value = val 
End Sub 

然後，只需將下面的代碼添加到您的模塊。私有常量需要在模塊級別（即頁面頂部）聲明。您可以使用這些來定義你的行和列的引用 - 它，如果他們匹配了飛行員的日誌，真的是不可思議的：

Private Const DB_SHEET As String = "Sheet1" 
Private Const DB_DATE_COL As String = "B" 
Private Const DB_ACCOUNT_COL As String = "C" 
Private Const DB_VALUE_COL As String = "G" 
Private Const DB_ACCOUNT_START_ROW As Long = 1 
Private Const DAY_DATE_ADDRESS As String = "A1" 
Private Const DAY_ACCOUNT_COL As String = "A" 
Private Const DAY_VALUE_COL As String = "B" 
Private Const DAY_ACCOUNT_START_ROW As Long = 2 


Public Sub ProcessData() 
    Dim daySheets As Collection 
    Dim accountsFromDB As Dictionary 
    Dim account As cAccountFields 
    Dim activity As cActivityFields 
    Dim ws As Worksheet 
    Dim dat As Date 
    Dim accName As String 
    Dim accValue As Double 
    Dim endRow As Long 
    Dim r As Long 

    ' Create a Collection of the Day sheets 
    Set daySheets = New Collection 
    For Each ws In ThisWorkbook.Worksheets 
     If Left(ws.Name, 4) = "Day " Then 
      daySheets.Add ws 
     End If 
    Next 

    ' Read the database sheet 
    Set ws = ThisWorkbook.Worksheets(DB_SHEET) 
    Set accountsFromDB = New Dictionary 

    endRow = ws.Cells.Find(What:="*", _ 
          After:=ws.Range("A1"), _ 
          LookIn:=xlFormulas, _ 
          LookAt:=xlPart, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious).Row 

    For r = DB_ACCOUNT_START_ROW To endRow 

     dat = ws.Cells(r, DB_DATE_COL).Value2 
     accName = ws.Cells(r, DB_ACCOUNT_COL).Text 
     accValue = ws.Cells(r, DB_VALUE_COL).Value2 

     ' Add the account or retrieve it if it already exists. 
     If Not accountsFromDB.Exists(accName) Then 
      Set account = New cAccountFields 
      account.Create accName 
      accountsFromDB.Add key:=accName, Item:=account 
     Else 
      Set account = accountsFromDB.Item(accName) 
     End If 

     ' Add the value for a specific date. 
     If Not account.ActivityByDate.Exists(dat) Then 
      Set activity = New cActivityFields 
      activity.Create dat, accValue 
      account.ActivityByDate.Add key:=dat, Item:=activity 
     Else 
      ' If the same account and date occurs, then aggregate the values. 
      Set activity = account.ActivityByDate(dat) 
      activity.Value = activity.Value + accValue 
     End If 

    Next 

    ' Populate the Day sheets 
    For Each ws In daySheets 

     dat = ws.Range(DAY_DATE_ADDRESS).Value2 

     endRow = ws.Cells.Find(What:="*", _ 
           After:=ws.Range("A1"), _ 
           LookIn:=xlFormulas, _ 
           LookAt:=xlPart, _ 
           SearchOrder:=xlByRows, _ 
           SearchDirection:=xlPrevious).Row 

     For r = DAY_ACCOUNT_START_ROW To endRow 

      accName = ws.Cells(r, DAY_ACCOUNT_COL).Text 

      ' If account and value for this date exists then write the value 
      If accountsFromDB.Exists(accName) Then 
       Set account = accountsFromDB.Item(accName) 
       If account.ActivityByDate.Exists(dat) Then 
        Set activity = account.ActivityByDate.Item(dat) 
        ws.Cells(r, DAY_VALUE_COL).Value = activity.Value 
       End If 
      End If 

     Next 

    Next 

End Sub 

後的OP Q的更新：在模塊級

添加額外的常量和適當的修改：

Private Const DB_BOOK As String = "Macro Test File.xlsx" 
Private Const DAY_BOOK As String = "Macro Test File.xlsx" 
Private Const INITIAL_SHEET As String = "Initial Revenue" 
Private Const INITIAL_COL As String = "E" 

然後使用此代碼：

Dim daySheets As Collection 
Dim accountsFromDB As Dictionary 
Dim account As cAccountFields 
Dim activity As cActivityFields 
Dim dbWb As Workbook 
Dim dayWb As Workbook 
Dim ws As Worksheet 
Dim dat As Date 
Dim accName As String 
Dim accValue As Double 
Dim endRow As Long 
Dim r As Long 

' Assign the workbook containing the database sheet 
On Error Resume Next 
Set dbWb = Workbooks(DB_BOOK) 
On Error GoTo 0 
If dbWb Is Nothing Then 
    MsgBox "Please open " & DB_BOOK & " in this application and run this routine again." 
    End 
End If 

' Assign the workbook containing the days sheets 
On Error Resume Next 
Set dayWb = Workbooks(DAY_BOOK) 
On Error GoTo 0 
If dayWb Is Nothing Then 
    MsgBox "Please open " & DAY_BOOK & " in this application and run this routine again." 
    End 
End If 


' Create a Collection of the Day sheets 
Set daySheets = New Collection 
For Each ws In dayWb.Worksheets 
    If Left(ws.Name, 4) = "Day " Then 
     daySheets.Add ws 
    End If 
Next 

' Read the database sheet 
Set ws = dbWb.Worksheets(DB_SHEET) 
Set accountsFromDB = New Dictionary 

endRow = ws.Cells.Find(What:="*", _ 
         After:=ws.Range("A1"), _ 
         LookIn:=xlFormulas, _ 
         LookAt:=xlPart, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlPrevious).Row 

For r = DB_ACCOUNT_START_ROW To endRow 

    dat = ws.Cells(r, DB_DATE_COL).Value2 
    accName = ws.Cells(r, DB_ACCOUNT_COL).Text 
    accValue = ws.Cells(r, DB_VALUE_COL).Value2 

    ' Add the account or retrieve it if it already exists. 
    If Not accountsFromDB.Exists(accName) Then 
     Set account = New cAccountFields 
     account.Create accName 
     accountsFromDB.Add Key:=accName, Item:=account 
    Else 
     Set account = accountsFromDB.Item(accName) 
    End If 

    ' Add the value for a specific date. 
    If Not account.ActivityByDate.Exists(dat) Then 
     Set activity = New cActivityFields 
     activity.Create dat, accValue 
     account.ActivityByDate.Add Key:=dat, Item:=activity 
    Else 
     ' If the same account and date occurs, then aggregate the values. 
     Set activity = account.ActivityByDate(dat) 
     activity.Value = activity.Value + accValue 
    End If 

Next 

' Populate the Day sheets 
For Each ws In daySheets 

    dat = ws.Range(DAY_DATE_ADDRESS).Value2 

    endRow = ws.Cells.Find(What:="*", _ 
          After:=ws.Range("A1"), _ 
          LookIn:=xlFormulas, _ 
          LookAt:=xlPart, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious).Row 

    For r = DAY_ACCOUNT_START_ROW To endRow 

     ' Write the standard formula into the cell 
     ws.Cells(r, DAY_VALUE_COL).Formula = "='" & INITIAL_SHEET & "'!" & _ 
              INITIAL_COL & CStr(r) 

     accName = ws.Cells(r, DAY_ACCOUNT_COL).Text 

     ' If account and value for this date exists then write the value 
     If accountsFromDB.Exists(accName) Then 
      Set account = accountsFromDB.Item(accName) 
      If account.ActivityByDate.Exists(dat) Then 
       Set activity = account.ActivityByDate.Item(dat) 
       ws.Cells(r, DAY_VALUE_COL).Formula = ws.Cells(r, DAY_VALUE_COL).Formula & _ 
                " + " & CStr(activity.Value) 
      End If 
     End If 

    Next 

Next