thisworkbook.activate
userform1.show vbmodeless

Option Explicit
Sub test2()
Dim ACTrng As Range, ACTcll As Range, STRlen&, STRlenMAX&, FSTrez As String, FNDpar As Range

Set ACTrng = ThisWorkbook.Worksheets("Лист2").ListObjects("TAB_3").ListColumns(1).DataBodyRange

With ThisWorkbook.Worksheets("Лист2")

'1й проход - находим ячейки с наибольшим кол-вом символов
Set ACTcll = ACTrng.Find("*", , xlValues, xlWhole, xlByColumns)
    STRlenMAX = Len(.Cells(ACTcll.Row, ACTcll.Column))
       
        If Not ACTcll Is Nothing Then
            FSTrez = ACTcll.Address
                
                Do
                    Set ACTcll = ACTrng.FindNext(ACTcll)
                    STRlen = Len(.Cells(ACTcll.Row, ACTcll.Column))
                        If STRlen > STRlenMAX Then STRlenMAX = STRlen
                Loop Until FSTrez = ACTcll.Address
        End If

'2й проход - находим самую нижнюю в древе подсборку
Set ACTcll = ACTrng.Find("*", , xlValues, xlWhole, xlByColumns)
    If Not ACTcll Is Nothing Then
            FSTrez = ACTcll.Address
                Do
                    Set ACTcll = ACTrng.FindNext(ACTcll)
                    STRlen = Len(.Cells(ACTcll.Row, ACTcll.Column))

                        If STRlen = STRlenMAX Then
                            MsgBox ACTcll
                            
                            'Set FNDpar = ACTrng.Find(Left(ACTcll, STRlen - 2), , xlValues, xlWhole, xlByColumns)
                            'MsgBox FNDpar
                        End If
                        
                        
                Loop Until FSTrez = ACTcll.Address
        End If
End With
End Sub

Option Explicit
Sub kkk()
Dim fcell As Range

Set fcell = ThisWorkbook.Worksheets("Лист1").Find("фыва", , xlValues, xlPart).Row
MsgBox fcell
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

If ActiveSheet.Name = "MB" Then user_menu.Show
Else
user_menu.Hide
end if
End Sub

ThisWorkbook.Worksheets("MB").ListObjects("tech_vis").DataBodyRange.Row(ListRows.Count).Select 

Sub dfs()
Dim i%, n%, ilastrow&, sh As Object

Set sh = ThisWorkbook.Worksheets("Лист1")

n = 1
ilastrow = sh.Cells(Rows.Count, 3).End(xlUp).Row
'ilastrow = ilastrow + 1
For i = 8 To ilastrow
  If .Cells(i, 2).MergeCells = True Then i = i + 1: _
    ElseIf sh.Cells(i, 2).MergeCells = False Then sh.Cells(i, 2) = n: n = n + 1: _
    With sh.Cells(i, 2): _
  .Font.Bold = False: _
  .HorizontalAlignment = xlCenter: _
  .VerticalAlignment = xlCenter: _
    End With
    End If
Next
End Sub

Sub merge()

Dim iLastRow%, perv As Object, wtor As Object

Set perv = ThisWorkbook.Worksheets("Первый")
Set wtor = ThisWorkbook.Worksheets("Второй")

With wtor
    iLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
    iLastRow = iLastRow + 1

wtor.Range(wtor.Cells(iLastRow, 1), wtor.Cells(iLastRow, 3)).merge
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Cells(iLastRow, 1) = "fgdfgd"
     
End Sub

Sub qewq()

Dim x, c, i As Integer

c = 2

    For x = 2 To Cells(Rows.Count, 3).End(xlUp).Row Step 1
    If Cells(x, 3) = "Овощи" Then ThisWorkbook.Worksheets("Первый").Range(Cells(x, 3).Offset(0, 1), Cells(x, 3).Offset(0, 2), Cells(x, 3).Offset(0, 6)).Copy
    ThisWorkbook.Worksheets("Второй").Range("B3").Paste
    c = c + 1
    Next

'With ThisWorkbook.Worksheets("Второй")
'For i = .Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
    'If .Cells(i, 2) = "" Then .Rows(i).EntireRow.Delete
'Next
'End With

End Sub

With ThisWorkbook.Worksheets("Второй")
For i = Cells(Rows.Count, 4).End(xlUp).Row To 20 Step -1
    If Cells(i, 4) = "" Then Rows(i).EntireRow.Delete

    r = Cells(Rows.Count, 4).End(xlUp).Row
    Rows(r + 1 & ":1048576").Hidden = True
            
    c = Cells(8, Columns.Count).End(xlToLeft).Column
    Columns(c + 1 & ":16384").Hidden = True

=ЕСЛИ(И(D6;E6)="";"Истина";"Ложь") 

Private Sub Worksheet_BeforerightClick(ByVal Target As Range, Cancel As Boolean)

    If Not Intersect(Target, Range("B8")) Is Nothing Then Range("Techtab[МСК]") = "a"
    Cancel = True
  
End Sub

Sub qwe()
  Const HRow = 8

Dim rg As Range

Set rg = Cells(Rows.Count, 2).End(xlUp) :     If IsEmpty(rg) Then Set rg = rg.End(xlUp)
  If rg.Row = HRow Then MsgBox "Нет отмеченных строк!", vbCritical, "Завершение работы": End

Sub qwe()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Integer, lr As Integer, w As String


Set ws1 = ThisWorkbook.Worksheets("ТТ")
Set ws2 = ThisWorkbook.Worksheets("МСК")
Set ws3 = ThisWorkbook.Worksheets("Back")


w = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
    
    Workbooks.Add (1)
        With ActiveWorkbook
            .SaveAs Filename:=ThisWorkbook.Path & "\МСК " & w & ".xls"
            '.Close True
        End With

lr = ws1.Cells(Rows.Count, 4).End(xlUp).Row
With ws2
For i = 9 To lr
    If ws1.Cells(i, 2) <> "" Then
    ws2.Copy , Worksheets(Worksheets.Count)
    wsC = Sheets.Count
    Sheets(wsC).Name = ws1.Cells(i, 2)
    Sheets(wsC).Cells(6, 43) = ws1.Cells(2, 16)
    Sheets(wsC).Cells(6, 1) = ws1.Cells(i, 6)
    Sheets(wsC).Cells(10, 1) = ws1.Cells(i, 14)
    Sheets(wsC).Cells(6, 23) = ws1.Cells(4, 16)
    
      
    End If
Next i

End With
Application.ScreenUpdating = True
End Sub

Sub create()
Dim w As String

Set w = ActiveWorkbook.Name
    Workbooks.Add (1)
        With ActiveWorkbook
            .SaveAs Filename:=ThisWorkbook.Path & "\МСК_" & w & ".xls"
        End With
End Sub

Sub qwe()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Integer, lr As Integer

Set ws1 = ThisWorkbook.Worksheets("ТТ")
Set ws2 = ThisWorkbook.Worksheets("МСК")
Set ws3 = ThisWorkbook.Worksheets("Back")

lr = ws1.Cells(Rows.Count, 4).End(xlUp).Row
With ws2
For i = 10 To lr
    If ws1.Cells(i, 1) <> "" Then
    ws2.Copy , Worksheets(Worksheets.Count)
    wsC = Sheets.Count
    Sheets(wsC).Name = ws1.Cells(i, 2)
    Sheets(wsC).Cells(6, 43) = ws1.Cells(2, 16)
    Sheets(wsC).Cells(6, 1) = ws1.Cells(i, 6)
    Sheets(wsC).Cells(10, 1) = ws1.Cells(i, 14)
    Sheets(wsC).Cells(6, 23) = ws1.Cells(4, 16)
    
    
    End If
Next i

End With
Application.ScreenUpdating = True
End Sub

Sub qwe()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Integer, lr As Integer


Set ws1 = ThisWorkbook.Worksheets("ТТ")
Set ws2 = ThisWorkbook.Worksheets("МСК")
Set ws3 = ThisWorkbook.Worksheets("Back")



lr = ws1.Cells(Rows.Count, 4).End(xlUp).Row
With ws2
For i = 10 To lr
    If ws1.Cells(i, 1) <> "" Then
    ws2.Copy , Worksheets(Worksheets.Count)
    wsC = Sheets.Count
    Sheets(wsC).Name = ws1.Cells(i, 2)
    Sheets(wsC).Cells(6, 43) = ws1.Cells(2, 16)
    Sheets(wsC).Cells(6, 1) = ws1.Cells(i, 6)
    Sheets(wsC).Cells(10, 1) = ws1.Cells(i, 14)
    Sheets(wsC).Cells(6, 23) = ws1.Cells(4, 16)

Next i
End With
End Sub

Private Sub Worksheet_BeforerightClick(ByVal Target As Range, Cancel As Boolean)
 With Target
     If .Column = 2 Then
         Select Case .Value
                 Case Is = "a"
                     .Font.Name = "Marlett"
                     .Value = ""
                 Case Else
                     .Font.Name = "Marlett"
                     .Value = "a"
         End Select
     Cancel = True
     End If
     
      If .Column = 3 Then
         Select Case .Value
                 Case Is = "a"
                     .Font.Name = "Marlett"
                     .Value = ""
                 Case Else
                     .Font.Name = "Marlett"
                     .Value = "a"
         End Select
     Cancel = True
     End If
     
 End With
End Sub

Sub New_wb()
    Dim New_wb As Workbook
    Dim wb_name As String
            
    Set New_wb = Workbooks.Add
    'New_wb.Activate
    Set wb_name = ThisWorkbook.Name
    
    New_wb.SaveAs Filename:=(ThisWorkbook.Path & "\" & "МСК" & " " & "wb_name" & ".xls")
    Sheets("МСК").Copy After:=Workbooks("МСК" & " " & "wb_name" & ".xls").Sheets(1)
    'New_wb.Close
End Sub