Sub test()
Dim nov() As Variant
Dim arr() As Variant
lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
arr = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
Worksheets.Add.Name = "List1"
Set a = ThisWorkbook.Sheets("List1")
ReDim nov(1 To UBound(arr), 1 To 16)
    For i = 1 To lLastCol
        nov(1, i) = arr(1, i)
    Next i
        For i = 2 To UBound(arr)
            For j = 2 To lLastRow
                If arr(i, 3) = nov(j, 3) _
                    And arr(i, 5) = nov(j, 5) _
                    And arr(i, 8) = nov(j, 8) _
                    And arr(i, 9) = nov(j, 9) _
                    And arr(i, 7) = nov(j, 7) Then
                        For k = 10 To 16
                            nov(j, k) = nov(j, k) + arr(i, k)
                        Next k
                        Exit For
                Else
                        If nov(j, 3) = "" Then
                            For k = 1 To lLastCol
                                nov(j, k) = arr(i, k)
                            Next k
                                nov(j, 6) = ""
                            Exit For
                        End If
                End If
            Next j
        Next i
a.Range(Cells(1, 1), Cells(UBound(nov), 16)) = nov
End Sub

Sub test()
Dim arr As Variant
lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
arr = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
Worksheets.Add.Name = "List1"
Set a = ThisWorkbook.Sheets("List1")
For i = 1 To lLastCol
a.Cells(1, i) = arr(1, i)
Next i
For i = 2 To UBound(arr)
For j = 2 To lLastRow
If arr(i, 3) = a.Cells(j, 3) _
And arr(i, 5) = a.Cells(j, 5) _
And arr(i, 8) = a.Cells(j, 8) _
And arr(i, 9) = a.Cells(j, 9) Then
For k = 10 To 16
a.Cells(j, k) = a.Cells(j, k) + arr(i, k)
Next k
Exit For
Else
If a.Cells(j, 3) = "" Then
For k = 1 To lLastCol
a.Cells(j, k) = arr(i, k)
Next k
a.Cells(j, 6) = ""
Exit For
End If
End If
Next j
Next i
End Sub

b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
b.Cells(q, 3) = a.Cells(i, 4)
b.Cells(q, 3) = a.Cells(i, 5)
b.Cells(q, 3) = a.Cells(i, 6)

b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
b.Cells(q, 4) = a.Cells(i, 4)
b.Cells(q, 5) = a.Cells(i, 5)
b.Cells(q, 6) = a.Cells(i, 6)

Sub test()
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
k = 0
Set a = Workbooks("Пример.xlsm").Sheets("Лист3")
For i = 2 To lLastRow
k = Cells(i, 3)
If Len(Dir(Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx")) > 0 Then
Workbooks.Open Filename:=Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx"
Set b = ActiveWorkbook.Sheets("Лист1")
lLastRowb = b.Cells(Rows.Count, 1).End(xlUp).Row
For q = 2 To lLastRowb + 1
If b.Cells(q, 1) = "" Then
b.Cells(q, 1) = b.Cells(q - 1, 1) + 1
Exit For
End If
Next q
b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
ActiveWorkbook.Close True
Else
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx"
Set b = ActiveWorkbook.Sheets("Лист1")
For q = 1 To 3
b.Cells(1, q) = a.Cells(1, q)
If q = 1 Then
b.Cells(2, q) = 1
Else
b.Cells(2, q) = a.Cells(i, q)
End If
Next q
ActiveWorkbook.Close True
End If
Next i
End Sub

Sub Макрос1()
Dim b, c, a
Set b = ThisWorkbook.Sheets("Для макроса")
Set c = ThisWorkbook.Sheets("С ФИО оф")
For a = 2 To 40 'Это тестовое число-может быть другим
If c.Cells(a, 2) <> "" And c.Cells(a, 23) <> "" And c.Cells(a, 26) <> "" And c.Cells(a, 27) <> "" _
And c.Cells(a, 28) <> "" And c.Cells(a, 31) <> "" And c.Cells(a, 32) <> "" And c.Cells(a, 33) <> "" Then
b.Cells(2, 1) = c.Cells(a, 2)
b.Cells(2, 2) = c.Cells(a, 23)
b.Cells(2, 3) = c.Cells(a, 26)
b.Cells(2, 4) = c.Cells(a, 27)
b.Cells(2, 5) = c.Cells(a, 28)
b.Cells(2, 6) = c.Cells(a, 31)
b.Cells(2, 7) = c.Cells(a, 32)
b.Cells(2, 8) = c.Cells(a, 33)
End If
'Тут стоит команда на печать нужного листа
Next a
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C3:H14")) Is Nothing Then
  If Target <> "" Then
  Call test
  Else
  Call test
  End If
End If
End Sub

"C3:H14"

 test

Sub test()
Dim c, i&
  c = Split(Cells(1, 1))
  For i = LBound(c) To UBound(c): c(i) = Left(c(i), 1): Next
  Cells(1, 2) = UCase(Join(c, ""))
End Sub

=ЛЕВСИМВ(A1;1)&ПРОПНАЧ(ПСТР(A1;ПОИСК(" ";A1)+1;1))&ПРОПНАЧ(ПСТР(A1;ПОИСК(" ";A1;ПОИСК(" ";A1)+1)+1;1))&ПРОПНАЧ(ПСТР(A1;ПОИСК(" ";A1;ПОИСК(" ";A1;ПОИСК(" ";A1)+1)+1)+1;1))

Sub Worksheet_See()
If [A1] = "основной" Then
Sheets("Ежемесячный бюджет").Visible = True
Sheets("Дополнительные данные").Visible = True
Sheets("Ежемесячные расходы").Visible = False
Else
Sheets("Ежемесячный бюджет").Visible = False
Sheets("Дополнительные данные").Visible = False
Sheets("Ежемесячные расходы").Visible = True
End If
End Sub

If [A1] = "основной" Then

If ThisWorkbook.Sheets("Лист1").Cells(1,1) = "основной" Then

=ЕСЛИ(F2<>" ";"ь";"")

Sub test2()
Dim d, a, i As Long
date3 = InputBox("Введите год")
If IsNumeric(date3) Then date3 = Year(DateSerial(CInt(date3), 1, 1)) Else Exit Sub
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1
a = ActiveSheet.Cells(2, 2).CurrentRegion.Value
For i = 2 To UBound(a)

  If Not d.exists(a(i, 2)) Then d(a(i, 2)) = 0
  If Year(a(i, 3)) = date3 Then d(a(i, 2)) = d(a(i, 2)) + 1
Next i
ActiveSheet.Cells(1, 8).Resize(1, d.Count) = d.keys
ActiveSheet.Cells(2, 8).Resize(1, d.Count) = d.items
End Sub

CreateObject("Scripting.Dictionary")

CurrentRegion