Скопируйте диапазон значений на основе даты в другом столбце

Question

Я пытаюсь написать макрос, который копирует диапазон значений в одном столбце на основе соответствующей даты в другом столбце.

Например, мне нужно скопировать значения в столбце G, соответствующие дате в столбце B. Для 9/18/2015 мне нужно выбрать и скопировать диапазон в столбце G на основе даты 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, который должен передавать ежедневные часы персональным листам пилотов. Переключить «учетную запись» на «пилот» и «количество» на «время полета», и наши проекты абсолютно одинаковы.

Я практически просто вырезал и наклеил свой код ниже, и он сделает весь шабанг для вас. В 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 

Обновлен после OPs Q'S:

Добавить дополнительные константы на уровне модуля и внести в них соответствующие:

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