Как создать новую форму, когда переменная равна новому месяцу

Question

В настоящее время у меня есть цикл, который проверяет, попадают ли ячейки в диапазон между двумя датами.Мой цикл в настоящее время создает новую форму для каждой ячейки, которая находится между заданными диапазонами дат.

Я хочу, чтобы мой цикл взял первый заданный диапазон дат и вывел сумму всех ячеек в пределах моего диапазона, попадающих в диапазон дат.Я также хочу, чтобы цикл называл ячейку над формой месяцем поиска.Мои диапазоны дат: startDate и endDate Код

Sub foo()
Dim oval As Shape
Dim rCell As Range
Dim rng As Range
Dim h As Integer
Dim w As Integer
Dim x As Long
Dim shp As Object
Dim counter As Long
Dim startDate As Date, endDate As Date
Set rng = Sheet1.Range("A1:B6")


h = 495
startDate = "01/01/2019"
endDate = "03/10/2019"

For Each rCell In rng
    If IsDate(rCell.Value) Then
        If rCell.Value >= startDate And rCell.Value <= endDate Then

            counter = counter + 1

            Set oval = ActiveSheet.Shapes.AddShape(msoShapeOval, h + 70 * (counter - 1), w + 125, 60, 65)

            With oval
                .Line.Visible = True
                .Line.Weight = 2
                .Fill.ForeColor.RGB = RGB(255, 255, 255)
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .TextFrame.Characters.Caption = rCell.Value
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Font.Size = 12
                .TextFrame.Characters.Font.Bold = True
                .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
            End With
        End If
    End If
Next rCell

End Sub

Желаемый результат

Токовый выход

Answer 1

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

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

 Sub BoOm()
Dim YourSTuff(1 To 12, 0 To 0) As Long, aCell As Range, YourRNG As Range, startDate As Date, endDate As Date

Set YourRNG = Range("A1:B99")

startDate = "01/01/2019"
endDate = "03/10/2019"


For Each aCell In YourRNG.Cells
    If IsDate(aCell.Value) Then
        If aCell.Value >= startDate And aCell.Value <= endDate Then
            YourSTuff(Month(aCell), 0) = YourSTuff(Month(aCell), 0) + 1
        End If
    End If
Next aCell


'when you're done.
Dim i As Long, c As Long
c = 1
    For i = LBound(YourSTuff) To UBound(YourSTuff)
        If YourSTuff(i, 0) > 0 Then


                Set Oval = ActiveSheet.Shapes.AddShape(msoShapeOval, h + 70 * (c), w + 125, 60, 65)
                c = c + 1

                With Oval
                    'not sure how to format as you want
                    .Line.Visible = True
                    .Line.Weight = 2
                    .Fill.ForeColor.RGB = RGB(255, 255, 255)
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                    .TextFrame.Characters.Caption = Choose(i, "January", "February", "March", "April", "May", "June", "" & _
                     "July", "August", "September", "October", "November", "December") & Chr(10) & YourSTuff(i, 0)
                    .TextFrame.HorizontalAlignment = xlHAlignCenter
                    .TextFrame.VerticalAlignment = xlVAlignCenter
                    .TextFrame.Characters.Font.Size = 12
                    .TextFrame.Characters.Font.Bold = True
                    .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
                End With
        End If


    Next i


End Sub