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

我试图编写一个宏，根据另一列中相应的日期复制一列中的一系列值

例如，我需要复制G列中与B列中日期相对应的值。对于2015年9月18日，我需要根据B列中2015年9月18日的日期选择并复制G列中的范围。然后，我需要对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

---

哦，这太可怕了。我现在有一个几乎相同的任务——除了我的是从SQL导入Excel的每月飞行日志，它必须将每天的工作时间转移到飞行员的个人工作表中。将“账户”切换为“飞行员”，将“金额”切换为“飞行时间”，我们的项目完全相同

我实际上只是在下面剪切粘贴了我的代码，它将为您完成整个沙邦。在StackOverflow上，为他们解决某人的整个任务并不是一个很好的形式，但在这种情况下，仅仅粘贴一点过程似乎是毫无意义的

对我来说，最大的教训是将Excel仅作为数据检索和数据显示界面。诀窍是创建自己的数据结构，将数据读入其中，根据需要对其进行操作/查询，然后在完成所有操作后将结果写入工作表。换句话说，避免像瘟疫一样使用宏生成器！我怀疑你复制x，y单元格粘贴到r，c单元格的方法会把你带到和我一样的死胡同。我找到的最好的方法是为你准备一本飞行员账户词典，然后为你准备一本飞行日期值/日期的内部词典。然后，您只需为日工作表中的每个帐户测试帐户密钥和日期密钥

要访问Dictionary对象，您需要参考Microsoft脚本运行时工具->参考…->通过勾选复选框在列表中选择

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

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

调用第二个cActivityFields并将以下代码添加到类中：

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

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

然后只需将以下代码添加到模块中。私有常量需要在页面顶部的模块级ie中声明。您可以使用这些来定义行和列引用-如果它们与飞行员的日志匹配，那真是不可思议：

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

---

也许我误解了这种情况，但听起来很可疑，目标选项卡上的一些VLookup公式可以在没有VBA的情况下实现这一点。有没有什么特别的原因让你不能用它们来代替呢？这可能会做到，但比这更复杂。我还需要代码来检查下一列C中的文本，以确定它将在工作表上对应的特定日期的哪个单元格。例如，将有一系列单元格对应于明天的9/18。一旦确定了该范围，我将需要代码来识别C列中的文本，并将其与另一页上的其他文本进行匹配，以确定将值粘贴到何处。我很难想象我们正在尝试实现什么。您能告诉我们更多关于数据结构的信息吗？B列是否是一组日期，您试图循环通过这些日期来测试它们是否介于明天和从今天开始的一周之间？看起来您将x设置为等于ActiveCell，但紧接着测试ActiveCell是否等于x。这似乎在所有情况下都是正确的。你能一步一步地解释一下你想让它做什么吗？当然，让我先解释一下我在看什么，这样你才能更好地理解这一点，然后我才能解释我想采取的步骤。我每天从一个数据库下载一份电子表格，该数据库的日期分组在B列，账户名称分组在C列，和F列中的金额。我在G列中创建了一个公式，以计算F列的百分比。B列中的每个日期对应9-12个账户，因此将有多行用于9/18，然后是多行用于9/19，依此类推。我还有36张其他的表，标记为第1天-第36天，其中一些表的日期将与日期匹配下载的表格。在每一张表上，都有一列包含所有帐户名，旁边的一列是我要粘贴下载表中相应日期和帐户名的值的位置。我需要为每个日期和每个帐户名这样做。现在我还停留在日期上，下一步将是帐户名。我以前没有使用过类，所以我对它们不熟悉。我在网上找了一个

---

有一点，但我在设置它们时遇到了麻烦。我需要做什么才能正确设置一个类？它们非常简单。您基本上是在创建自己的对象，该对象与任何其他对象一样具有方法和属性。例如，在代码中，Active工作簿是对象的实例，而工作表是其属性之一。要设置类，请在菜单栏上单击“插入->类模块”。在“属性”窗口编辑器的左下角，可以键入其名称。默认值为Class1。右边是您输入代码的地方，就像任何模块一样。感谢您对这些类的帮助。这是一件非常简单的事情。我现在得到了错误对象变量或With block变量not set，当我单击debug时，它将我指向代码的endRow部分。听起来好像工作表对象有问题。在模块顶部检查您是否已为常数DB_工作表指定了工作表的名称。如果这是正确的，请在代码中放入以下行，运行它并告诉我它说了什么。Print ws Is Nothing=&ws Is Nothing&。工作表为&ActiveSheet.Name。输出将位于即时窗口编辑器的底部。您是对的，该名称不正确。我纠正了它，现在它告诉我下标在设置ws时超出范围。