Sub Condition_vibor4()

Dim i As Integer, j As Integer

'Описываем цикл
For i = 7 To 20 '7 - начало строки массива данных, а 20 - конец массива (можно заменить на "последнюю строку"

For j = 1 To 5 '1 - начальная строка для размещения данных, 5 - число зарезервированных строк под двнные

' условие для остановки макроса при достижении i = 20 и более
If i > 19 Then
End
End If
'

If Cells(i, 8) > 0 And Cells(j, 9) <> Cells(i, 7) And Cells(i, 7) <> Cells(i + 1, 7) Then
Cells(j, 9) = Cells(i, 7).Value
Cells(1, 10) = "=SumIf($G$7:$G$16,I1,$H$7:$H$16)"
i = i + 1
Else

If i = 18 Then
countvalues = Application.WorksheetFunction.CountA(Range("I1:I5"))
Cells(1, 10).Select
    Selection.AutoFill Destination:=Range("J1:J" & countvalues), Type:=xlFillDefault
End If

i = i + 1
j = j - 1
End If

Next j
Next i

End Sub

Private Sub txt1_Change()
  If Me.txt1.Value > 0 And Me.txt2.Value > 0 Then
  Me.lbltext.Visible = True
  Else: Me.lbltext.Visible = False
  End If
End Sub

Option Explicit

Private Sub cmdAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("PartsData")

'''find  first empty row in database
''iRow = ws.Cells(Rows.Count, 1) _
''  .End(xlUp).Offset(1, 0).Row
'revised code to avoid problems with Excel tables in newer versions
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1

'check for a part number
If Trim(Me.txtPart.Value) = "" Then
  Me.txtPart.SetFocus
  MsgBox "Please enter a part number"
  Exit Sub
End If

'copy the data to the database
ws.Cells(iRow, 1).Value = Me.txtPart.Value
ws.Cells(iRow, 2).Value = Me.txtLoc.Value
ws.Cells(iRow, 3).Value = Me.txtDate.Value
ws.Cells(iRow, 4).Value = Me.txtQty.Value

'clear the data
Me.txtPart.Value = ""
Me.txtLoc.Value = ""
Me.txtDate.Value = ""
Me.txtQty.Value = ""
Me.txtPart.SetFocus

End Sub

wda.WindowState = wdWindowStateMinimize
Windows("tesr.xlsm").Activate
UserForm1.Show

For vib = 1 To 10

wda.WindowState = wdWindowStateMinimize
Windows("tesr.xlsm").Activate
UserForm1.Show

'''''''''''''''''''''''''
'''''''''ЦИКЛ'''''''''''
'''''''''''''''''''''''''

''''
Range("C7:F15").Select
Selection.Copy
''''
With wda
.ActiveDocument.Bookmarks("ob_1").Select

End With

wda.Selection.PasteSpecial False, False, False

'
Application.CutCopyMode = False
'Очистка буфера обмена

''''
Range("C1:E5").Select
Selection.Copy
''''
With wda
.ActiveDocument.Bookmarks("ob_2").Select

End With

wda.Selection.PasteSpecial False, False, False

'
Application.CutCopyMode = False
'Очистка буфера обмена

''''
wda.Activate
wda.Selection.TypeParagraph
wda.Selection.TypeParagraph
wda.Selection.TypeText Text:="ob_1"
wda.Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
wda.Selection.Bookmarks.Add Name:="ob_1"
wda.Selection.MoveRight Unit:=wdCharacter, Count:=5, Extend:=wdExtend
wda.Selection.TypeParagraph
wda.Selection.TypeParagraph
''''

wda.Activate
wda.Selection.TypeParagraph
wda.Selection.TypeParagraph
wda.Selection.TypeText Text:="ob_2"
wda.Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
wda.Selection.Bookmarks.Add Name:="ob_2"
wda.Selection.MoveRight Unit:=wdCharacter, Count:=5, Extend:=wdExtend
wda.Selection.TypeParagraph
wda.Selection.TypeParagraph
''''

'''''''''''''''''''''''''
''''''КОНЕЦ ЦИКЛА'''''''
'''''''''''''''''''''''''
Next vib

End Sub

Sub forum()

Dim wda As Word.Application

On Error Resume Next

Range("C7:F15").Select
Selection.Copy
 
    On Error Resume Next

    Set wda = CreateObject("Word.Application")    ' создаём приложение Word (без подключения библиотеки Word)

    wda.Visible = True    ' делаем Word видимым
    
    Set wd = wda.Documents.Open("U:\Шаблоны\forum.docm")
 
With wda
.ActiveDocument.Bookmarks("ob_1").Select

End With

wda.Selection.PasteSpecial False, False, False

'
Application.CutCopyMode = False
'Очистка буфера обмена

wda.Activate
wda.Selection.TypeParagraph
wda.Selection.TypeParagraph
wda.Selection.TypeText Text:="ob_1"
wda.Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:="ob_1"
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With
    
End Sub

Sub Макрос4()

   Dim k As Integer, m As Integer

k = Cells(3, 10)
m = Cells(2, 10)
If m <> "0" Then
    Range("J" & k & ":K" & k + m).Copy
    End If

End Sub

Sub Format_Excel_Word_transfer()
Dim wda As Word.Application
  
Set wda = CreateObject("Word.Application")
  
With wda
.Visible = True
.Documents.Open "U:\Format_Excel_Word_transfer\Templateform.dotx"
.ActiveDocument.Bookmarks("Table_0").Select
End With
  
Worksheets("Sheet1").Activate
Range("A1:B2").Copy
wda.Selection.PasteSpecial False, False, False

With wda
.Visible = True
.Documents.Open "U:\Format_Excel_Word_transfer\Templateform.dotx"
.ActiveDocument.Bookmarks("bookmark_3").Select
End With
  
Worksheets("Sheet1").Activate
Range("C2").Copy
wda.Selection.PasteSpecial

With wda
.Visible = True
.ActiveDocument.SaveAs Filename:= _
        "U:\Format_Excel_Word_transfer\" & "Test " & Format(Now, "ddMMyy") & ".docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False
End With
End Sub

Sub OpenDocument()
 
Dim wda As Word.Application
 
Set wda = CreateObject("Word.Application")
 
With wda
.Visible = True
.Documents.Open "U:\Documentik.docx"
.ActiveDocument.Bookmarks("Pervaya").Select
End With
 
Worksheets("qwerty").Activate
Range("B1").Copy
wda.Selection.PasteSpecial

With wda
.Visible = True
.Documents.Open "U:\Documentik.docx"
.ActiveDocument.Bookmarks("Vtoraya").Select
End With

Range("C1").Copy
wda.Selection.PasteSpecial
 
End Sub

ActiveCell.FormulaR1C1 = "=R[-10]C[-1]+R[-10]C+100"
    Range("D12").Select
    Range("D12").Comment.Text Text:="=СУММ(C2;D2)+100"
    Range("E10").Select
End Sub

=ЕСЛИОШИБКА(ИНДЕКС($B$2:$B$16;НАИМЕНЬШИЙ(ЕСЛИ(A2:A16<=4;СТРОКА(B2:B16)-1;"");СТРОКА()-5));"")

Sub Form()

Range("C27").Select
    ActiveCell.Value = Application.InputBox("Количество фруктов в фуре")

End Sub

=(ЧПС(G$27;$K$13:$N$13)+($N$13*(1+$F28)/(G$27-$F28))*(1/(1+G$27)^$N$2)-$M$20)

=ЧПС(C16;K13:N13)

=(ЧПС(G$27;$L$13:$N$13)+($N$13*(1+$F28)/(G$27-$F28))*(1/(1+G$27)^$N$2)-$M$20)

=ЧПС(C16;L13:N13)

Sub Knopka()
'
' Knopka ??????
'

'
    ActiveSheet.Buttons.Add(200.25, 97.5, 89.25, 27).Select
    Selection.OnAction = "Zalivka"
    Selection.Characters.Text = "GO"
    With Selection.Characters(Start:=1, Length:=17).Font
        .Name = "Calibri"
        .FontStyle = "Bold"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    Range("G10").Select
End Sub

Sub Zalivka()
'
' Zalivka ??????
'

'
    Range("B15:B50").Select
    Range("B15:B50,B60:B95").Select
    Range("B60").Activate
    Range("B15:B50,B60:B95,B106:B141").Select
    Range("B106").Activate
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=0"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub