根据另一列中的日期复制一系列值

Question

我正在尝试编写一个宏，它根据另一列中的相应日期在一列中复制一系列值。

例如，我需要复制G列中与B列中日期对应的值。对于2015年9月18日，我需要根据日期9/18/2015选择并复制G列中的范围从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（工具 - ＆gt;引用... - ＆gt;通过勾选复选框在列表中选择）。

您需要创建两个类 - 这些是您的数据字段。调用第一个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

在OPs 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