Блог

У меня есть таблица часов по неделям (начало недели-воскресенье). Еженедельные данные увеличиваются до 12-16 месяцев в зависимости от ввода пользователем. Я хочу создать макрос VBA, который будет повторять эту таблицу данных о часах за неделю и преобразовывать столбцы в данные за месяц.

Пример: Все столбцы, связанные с октябрем 2021 года, будут свернуты в 1 столбец, называемый 21 октября. Это также позволит объединить часы. 2-я строка на изображении ниже будет равна 4 3 4 0= следовательно, значение будет равно 11 во 2-й строке нового объединенного столбца.

Мое текущее мышление состояло в расчете воскресений между датой начала и последней датой, которая указана ниже:

 Dim d As Date, format As String, w As Long, FirstSunday As String
format = format(lastMonth, "Medium Date")
d = DateSerial(Year(format), Month(format), 1)
w = Weekday(d, vbSunday)
FirstSunday = d   IIf(w <> 1, 8 - w, 0)
 

Есть какие-нибудь идеи о том, как это сделать?

Не уверен, как вы хотите сгруппировать недели в месяцы, так как в некоторых месяцах будет 5 недель. Этот код вставляет столбец при изменении месяца, а затем заполняет его формулой суммы для соответствующих столбцов недели. Предполагается , что даты указаны в строке 1, номера задач в столбце 1 и первая неделя указаны в столбце 2.

 Option Explicit

Sub ByMonth()

    Dim wb As Workbook, ws As Worksheet
    Dim LastCol As Long, LastRow As Long, c As Long, n As Long
    Dim dt As Date

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    ' scan cols from right to left insert new columns
    Application.ScreenUpdating = False
    For c = LastCol   1 To 3 Step -1
        ' add columns on month change
        If Month(ws.Cells(1, c)) <> Month(ws.Cells(1, c - 1)) Then
             ws.Columns(c).Insert
             With ws.Columns(c)
                .HorizontalAlignment = xlCenter
                '.Interior.Color = RGB(255, 255, 200)
                .Font.Bold = True
                .Cells(1).NumberFormat = "@"
             End With
        End If
    Next

    ' scan left to right filling new cols with sum() formula
    ' hide weekly columns
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    n = 0
    For c = 2 To LastCol   1
       If ws.Cells(1, c) = "" Then
          dt = ws.Cells(1, c - 1)
          ws.Cells(1, c) = MonthName(Month(dt), True) amp; "  " amp; Year(dt)
          ws.Cells(2, c).Resize(LastRow - 1).FormulaR1C1 = "=SUM(RC[-" amp; n amp; "]:RC[-1])"
          n = 0
       Else
          ws.Columns(c).EntireColumn.Hidden = True
          n = n   1
       End If
    Next

    ' copy visible month columns to sheet2
    ws.Cells.SpecialCells(xlCellTypeVisible).Copy
    With wb.Sheets("Sheet2")
        .Activate
        .Range("A1").PasteSpecial xlPasteValues
        .Range("A1").Select
    End With
      
    ' end
    ws.Columns.Hidden = False
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Done"

End Sub
 

Пожалуйста, попробуйте следующий код. Это предполагает, что в столбце A:A, начиная с 6-й строки, есть (не отсортированные) задачи. Если они будут отсортированы, код тоже будет выполняться без проблем. Он использует массивы и словарь и в основном работает в памяти, должен быть очень быстрым для больших диапазонов:

 Sub SumWeeksMonths()
  Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arrWk, arrMonths, arrTasks
  Dim i As Long, k As Long, j As Long, El, arr, arrFin, dict As New Scripting.Dictionary
  
  Set sh = ActiveSheet 'use there the sheet to be processed
  Set sh1 = sh.Next    'use here the sheet where the processed result to be returned
  lastR = sh.Range("A" amp; sh.rows.count).End(xlUp).row 'last row (in column A:A)
  arrWk = sh.Range(sh.Range("B5"), sh.cells(5, sh.Columns.count).End(xlToLeft)).Value 'place the Week headers in a 2D array
  ReDim arrMonths(UBound(arrWk, 2) - 1)'redim the 1D array to keep the unique munths, at a maximum size
  For i = 1 To UBound(arrWk, 2) - 1    'create the array of (only) months:
        If month(DateValue(arrWk(1, i))) <> month(DateValue(arrWk(1, i   1))) Then
            k = k   1: arrMonths(k) = Format(DateValue(arrWk(1, i   1)), "mmm-yyyy")
        Else
            arrMonths(k) = Format(DateValue(arrWk(1, i)), "mmm-yyyy")
        End If
  Next i
  ReDim Preserve arrMonths(k) 'preserve only the existing Date elements
  For Each El In sh.Range("A4:A" amp; lastR).Value
     dict(El) = 1 'extract the unique tasks (only to count them for ReDim the necessary array)
 Next El
  'place all the range to be processed in an array (for faster iteration):
  arr = sh.Range("A5", sh.cells(lastR, sh.cells(5, sh.Columns.count).End(xlToLeft).Column)).Value
  ReDim arrFin(1 To UBound(dict.Keys)   1, 1 To UBound(arrMonths)   2) 'reDim the final array to keep processed data
  ReDim arrTasks(UBound(arrMonths))  'redim the array to temporarily keep the array of each task summ
  dict.RemoveAll: k = 0  'clear the dictionary and reitinialize the K variable
  
  For i = 2 To UBound(arr)              'iterate between the main array elements:
     If Not dict.Exists(arr(i, 1)) Then 'if the Task key does not exist:
        For Each El In arrMonths        'iterate between each month in arrMonths:
            For j = 2 To UBound(arr, 2) 'iterate between all arr columns for the i row:
                If month(DateValue(arr(1, j))) = month(El) Then 'if column months is a specific arrMonths column:
                    arrTasks(k) = arrTasks(k)   arr(i, j)               'sumarize everything in the arrTask each element
                End If
         Next j
         k = k   1                      'increment k, for the next month
       Next El
       dict.Add arr(i, 1), arrTasks     'create the dictionary key with the tasks array as item
       ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
    Else                                        'if dictionary (task) key exists:
        For Each El In arrMonths
            For j = 2 To UBound(arr, 2)
                If month(DateValue(arr(1, j))) = month(El) Then
                    arrTasks(k) = dict(arr(i, 1))(k)   arr(i, j) 'add the sum to the allready existing elements
                End If
         Next j
         k = k   1
       Next El
       dict(arr(i, 1)) = arrTasks                     'make the item the updaded array
       ReDim arrTasks(UBound(arrMonths)): k = 0       'reinitialize arrTasks and k variable
    End If
  Next i

  'place the processed values in final array (arrFin):
  For i = 0 To UBound(arrMonths) 'firstly the headers:
        arrFin(1, i   2) = arrMonths(i)
  Next i
  'Extract the tasks value for each month and place in the final array appropriate columns:
  For i = 0 To dict.count - 1           'iterate between the dictionary elements:
      arrFin(i   2, 1) = dict.Keys(i)   'place the task in the array first column, starting from the second row
     For j = 0 To UBound(dict.items(i)) 'iterate between the dictionary item array elements
        arrFin(i   2, j   2) = dict.items(i)(j) 'place the appropriate array elements in the final array (arrFin)
     Next j
  Next i
  'drop the final array at once and make some formatting:
  With sh1.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
    .Value = arrFin
    With .rows(1)
        .Font.Bold = True
        .Interior.ColorIndex = 20
        .BorderAround 1
    End With
    .EntireColumn.AutoFit
    .BorderAround 1
 End With
 sh1.Activate 'to see the processing result...
 MsgBox "Ready..."
End Sub
 

Пожалуйста, протестируйте его и отправьте несколько отзывов.