Public Sub InitToolBar()
Dim cmdBarSm As CommandBar
Dim ctlNewbtn As CommandBarButton
'Application.CommandBars("MyToolBar").Controls(" ").Delete
'Application.CommandBars("MyToolBar").Controls(" ").Delete
'Application.CommandBars("MyToolBar").Controls(" ").Delete
Set cmdBarSm = Application.CommandBars("MyToolBar")
Set ctlNewbtn = cmdBarSm.Controls.Add(msoControlButton)
ctlNewbtn.Caption = " "
ctlNewbtn.FaceId = 26
ctlNewbtn.OnAction = "getMonth"
Set ctlNewbtn = cmdBarSm.Controls.Add(msoControlButton)
ctlNewbtn.Caption = " "
ctlNewbtn.FaceId = 28
ctlNewbtn.OnAction = "getDay"
Set ctlNewbtn = cmdBarSm.Controls.Add(msoControlButton)
ctlNewbtn.Caption = " "
ctlNewbtn.FaceId = 31
ctlNewbtn.OnAction = "GetGroup"
End Sub
Sub getMonth()
Dim ActSheet As Worksheet
Dim BeginCell As Integer
Dim SumCell As Integer
Dim CurSumCell As Integer
Dim NewData As Boolean
Dim CurData As Date
Dim ValueP As Integer
Dim MonthNow As String
'
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Range("A5", "D65536").Select
Selection.Clear
'
Set ActSheet = Worksheets.Item("3")
BeginCell = 2
CurSumCell = 5
ActSheet.Activate
While ActSheet.Cells(BeginCell, 1).Value <> Empty
NewData = True
SumCell = 5
CurData = ActSheet.Cells(BeginCell, 1).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
'
While ActSheet.Cells(SumCell, 1).Value <> Empty
If MonthName(Month(CurData)) = ActSheet.Cells(SumCell, 1).Value Then
NewData = False
End If
SumCell = SumCell + 1
Wend
'
If NewData Then
ActSheet.Cells(CurSumCell, 1).Value = MonthName(Month(CurData))
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell, 3).Value = ActSheet.Cells(CurSumCell, 3).Value + ValueP
CurSumCell = CurSumCell + 1
End If
'
If Not NewData Then
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell - 1, 3).Value = ActSheet.Cells(CurSumCell - 1, 3).Value + ValueP
End If
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
BeginCell = BeginCell + 1
Wend
'
Set ActSheet = Worksheets.Item("1")
BeginCell = 2
CurSumCell = 5
ActSheet.Activate
' A
While ActSheet.Cells(BeginCell, 1).Value <> Empty
NewData = True
SumCell = 5
CurData = ActSheet.Cells(BeginCell, 1).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
'
MonthNow = ActSheet.Cells(SumCell, 1).Value
While ActSheet.Cells(SumCell, 1).Value <> Empty
If MonthName(Month(CurData)) = ActSheet.Cells(SumCell, 1).Value Then
NewData = False
End If
SumCell = SumCell + 1
Wend
'
If NewData Then
ActSheet.Cells(CurSumCell, 1).Value = MonthName(Month(CurData))
Set ActSheet = Worksheets.Item("1")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell, 2).Value = ActSheet.Cells(CurSumCell, 2).Value + ValueP
CurSumCell = CurSumCell + 1
End If
'
If Not NewData Then
Set ActSheet = Worksheets.Item("1")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
If ActSheet.Cells(CurSumCell - 1, 1).Value <> MonthName(Month(CurData)) Then
ActSheet.Cells(CurSumCell, 4).FormulaR1C1 = "=RC[-2]-RC[-1]"
CurSumCell = CurSumCell + 1
End If
ActSheet.Cells(CurSumCell - 1, 2).Value = ActSheet.Cells(CurSumCell - 1, 2).Value + ValueP
End If
Set ActSheet = Worksheets.Item("1")
ActSheet.Activate
BeginCell = BeginCell + 1
Wend
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
End Sub
Sub getDay()
Dim ActSheet As Worksheet
Dim BeginCell As Integer
Dim SumCell As Integer
Dim CurSumCell As Integer
Dim NewData As Boolean
Dim CurData As Date
Dim ValueP As Integer
Dim MonthNow As String
'
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Range("F5", "G65536").Clear
'
Set ActSheet = Worksheets.Item("3")
BeginCell = 2
CurSumCell = 5
ActSheet.Activate
While ActSheet.Cells(BeginCell, 1).Value <> Empty
NewData = True
SumCell = 5
CurData = ActSheet.Cells(BeginCell, 1).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
'
While ActSheet.Cells(SumCell, 6).Value <> Empty
If CurData = ActSheet.Cells(SumCell, 6).Value Then
NewData = False
End If
SumCell = SumCell + 1
Wend
'
If NewData Then
ActSheet.Cells(CurSumCell, 6).Value = CurData
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell, 7).Value = ActSheet.Cells(CurSumCell, 7).Value + ValueP
CurSumCell = CurSumCell + 1
End If
'
If Not NewData Then
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell - 1, 7).Value = ActSheet.Cells(CurSumCell - 1, 7).Value + ValueP
End If
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
BeginCell = BeginCell + 1
Wend
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
End Sub
Sub GetGroup()
Dim ActSheet As Worksheet
Dim BeginCell As Integer
Dim SumCell As Integer
Dim CurSumCell As Integer
Dim NewData As Boolean
Dim CurGroup As String
Dim ValueP As Integer
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Range("I5", "J65536").Clear
Set ActSheet = Worksheets.Item("3")
BeginCell = 2
CurSumCell = 5
ActSheet.Activate
While ActSheet.Cells(BeginCell, 3).Value <> Empty
NewData = True
SumCell = 5
CurGroup = ActSheet.Cells(BeginCell, 3).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
'
While ActSheet.Cells(SumCell, 9).Value <> Empty
If CurGroup = ActSheet.Cells(SumCell, 9).Value Then
NewData = False
CurSumCell = SumCell + 1
End If
SumCell = SumCell + 1
Wend
'
If NewData Then
If ActSheet.Cells(CurSumCell, 9).Value <> Empty Then
CurSumCell = CurSumCell + 1
End If
ActSheet.Cells(CurSumCell, 9).Value = CurGroup
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell, 10).Value = ActSheet.Cells(CurSumCell, 10).Value + ValueP
CurSumCell = CurSumCell + 1
End If
'
If Not NewData Then
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
ValueP = ActSheet.Cells(BeginCell, 2).Value
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActSheet.Cells(CurSumCell - 1, 10).Value = ActSheet.Cells(CurSumCell - 1, 10).Value + ValueP
End If
Set ActSheet = Worksheets.Item("3")
ActSheet.Activate
BeginCell = BeginCell + 1
Wend
Set ActSheet = Worksheets.Item("")
ActSheet.Activate
ActiveSheet.Shapes("Chart 1").Select
ActiveChart.SetSourceData Source:=Sheets("").Range("I5:J" + CStr(CurSumCell - 1)), PlotBy:= _
xlColumns
End Sub
ActiveSheet.Shapes("Chart 1").Select
ActiveChart.SetSourceData Source:=Sheets("").Range("I5:J" + CStr(CurSumCell - 1)), PlotBy:= _
xlColumns
Source: https://habr.com/ru/post/111412/
All Articles