Private Sub Worksheet_Change(ByVal Target As Range) Dim s$, x$, v As Variant If Not Intersect(Target, Range("E3")) Is Nothing Then s = Target.Validation.Formula1 v = Evaluate(s) If Left(s, 1) = "=" Then If TypeName(v) = "Range" Then v = v.Formula x = Join(Application.Transpose(v), ";") Else: x = s End If Select Case UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) Case 1: Call Макрос_1 Case 2: Call Макрос_2 Case 3: Call Макрос_3 End Select
'ИЛИ 'Application.Run "Макрос_" & UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) End If End Sub
[/vba]
Здравствуйте. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim s$, x$, v As Variant If Not Intersect(Target, Range("E3")) Is Nothing Then s = Target.Validation.Formula1 v = Evaluate(s) If Left(s, 1) = "=" Then If TypeName(v) = "Range" Then v = v.Formula x = Join(Application.Transpose(v), ";") Else: x = s End If Select Case UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) Case 1: Call Макрос_1 Case 2: Call Макрос_2 Case 3: Call Макрос_3 End Select
'ИЛИ 'Application.Run "Макрос_" & UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) End If End Sub
Sub Макрос1() Dim o1 As Shape, o2 As Shape Dim x1!, y1!, r1!, x2!, y2!, r2!, xa!, ya!, xb!, yb! Dim col As Range For Each col In [A3:E6].Columns On Error Resume Next Set o1 = ActiveSheet.Shapes(col.Cells(1)) Set o2 = ActiveSheet.Shapes(col.Cells(4)) If Not (o1 Is Nothing Or o2 Is Nothing) Then GetParam o1, x1, y1, r1 GetParam o2, x2, y2, r2 Dim i&, j&, p#, l!, lmin! Dim x1t!, y1t!, x2t!, y2t!, bc&, ec& p = Atn(1) lmin = [a65536].Top - [a1].Top For i = 0 To 7 x1t = x1 + Cos(p * i) * r1 y1t = y1 - Sin(p * i) * r1 For j = 0 To 7 x2t = x2 + Cos(p * j) * r2 y2t = y2 - Sin(p * j) * r2 l = Sqr((x1t - x2t) ^ 2 + (y1t - y2t) ^ 2) If l < lmin Then lmin = l xa = x1t ya = y1t xb = x2t yb = y2t bc = i ec = j End If Next Next With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, xa, ya, xb, yb) .ConnectorFormat.BeginConnect o1, (bc + 6) Mod 8 + 1 .ConnectorFormat.EndConnect o2, (ec + 6) Mod 8 + 1 .Name = col.Cells(1) & "|" & col.Cells(4) End With End If Next End Sub
[/vba]
Здравствуйте. Можно как-то так [vba]
Код
Sub Макрос1() Dim o1 As Shape, o2 As Shape Dim x1!, y1!, r1!, x2!, y2!, r2!, xa!, ya!, xb!, yb! Dim col As Range For Each col In [A3:E6].Columns On Error Resume Next Set o1 = ActiveSheet.Shapes(col.Cells(1)) Set o2 = ActiveSheet.Shapes(col.Cells(4)) If Not (o1 Is Nothing Or o2 Is Nothing) Then GetParam o1, x1, y1, r1 GetParam o2, x2, y2, r2 Dim i&, j&, p#, l!, lmin! Dim x1t!, y1t!, x2t!, y2t!, bc&, ec& p = Atn(1) lmin = [a65536].Top - [a1].Top For i = 0 To 7 x1t = x1 + Cos(p * i) * r1 y1t = y1 - Sin(p * i) * r1 For j = 0 To 7 x2t = x2 + Cos(p * j) * r2 y2t = y2 - Sin(p * j) * r2 l = Sqr((x1t - x2t) ^ 2 + (y1t - y2t) ^ 2) If l < lmin Then lmin = l xa = x1t ya = y1t xb = x2t yb = y2t bc = i ec = j End If Next Next With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, xa, ya, xb, yb) .ConnectorFormat.BeginConnect o1, (bc + 6) Mod 8 + 1 .ConnectorFormat.EndConnect o2, (ec + 6) Mod 8 + 1 .Name = col.Cells(1) & "|" & col.Cells(4) End With End If Next End Sub
Sub xx() With Application .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = False Open ActiveWorkbook.Path & "\8037208.txt" For Input As #1 With GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText Input$(LOF(1), 1) .PutInClipboard End With Close #1 With [C5:F5] Range(.Cells, .End(xlDown)).ClearContents .Cells(1).PasteSpecial xlPasteAll .Copy End With .CutCopyMode = 0 .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1 End With End Sub
[/vba]
еще вариант[vba]
Код
Sub xx() With Application .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = False Open ActiveWorkbook.Path & "\8037208.txt" For Input As #1 With GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText Input$(LOF(1), 1) .PutInClipboard End With Close #1 With [C5:F5] Range(.Cells, .End(xlDown)).ClearContents .Cells(1).PasteSpecial xlPasteAll .Copy End With .CutCopyMode = 0 .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1 End With End Sub
Private Sub CommandButton1_Click() Dim var As Variant, sel As Range, s% Set sel = Selection.Range Application.ScreenUpdating = False s = ActiveDocument.Windows(1).VerticalPercentScrolled For Each var In Array("Текст1", "ТекстМ2", "Текст3К") With Selection.Find .ClearFormatting .Wrap = wdFindContinue .Text = var .Execute Do Selection.Collapse wdCollapseEnd Selection.Range.Paragraphs(1).Style = ActiveDocument.Styles(-2) .Execute Loop Until Not .Found End With Next sel.Select ActiveDocument.Windows(1).VerticalPercentScrolled = s Application.ScreenUpdating = True End Sub
[/vba] в части кода [vba]
Код
ActiveDocument.Styles(-2)
[/vba] -2=-1-УровеньЗаголовка
Добрый вечер. [vba]
Код
Private Sub CommandButton1_Click() Dim var As Variant, sel As Range, s% Set sel = Selection.Range Application.ScreenUpdating = False s = ActiveDocument.Windows(1).VerticalPercentScrolled For Each var In Array("Текст1", "ТекстМ2", "Текст3К") With Selection.Find .ClearFormatting .Wrap = wdFindContinue .Text = var .Execute Do Selection.Collapse wdCollapseEnd Selection.Range.Paragraphs(1).Style = ActiveDocument.Styles(-2) .Execute Loop Until Not .Found End With Next sel.Select ActiveDocument.Windows(1).VerticalPercentScrolled = s Application.ScreenUpdating = True End Sub
для того, чтобы использовать серверную версию надстройки достаточно подключить ее через параметры Excel (без копирования в папку, предварительно удалив файл надстройки из %appdata%\microsoft\AddIns и %appdata%\microsoft\excel\xlstart) или можно использовать такой макрос [vba]
Код
On Error Resume Next Set excelapp = GetObject(, "excel.application") If excelapp Is Nothing Then Err.Clear Set excelapp = CreateObject("excel.application") excelapp.Workbooks.Add End If With excelapp with .AddIns .Add "\\Server\общая\Program Files\Microsoft Office\ADDINS\md5.xlam", False .Item("md5").Installed = true End With If Err = 0 Then MsgBox "надстройка md5 установлена успешно" if not excelapp.visible then excelapp.quit end with
[/vba]
для того, чтобы использовать серверную версию надстройки достаточно подключить ее через параметры Excel (без копирования в папку, предварительно удалив файл надстройки из %appdata%\microsoft\AddIns и %appdata%\microsoft\excel\xlstart) или можно использовать такой макрос [vba]
Код
On Error Resume Next Set excelapp = GetObject(, "excel.application") If excelapp Is Nothing Then Err.Clear Set excelapp = CreateObject("excel.application") excelapp.Workbooks.Add End If With excelapp with .AddIns .Add "\\Server\общая\Program Files\Microsoft Office\ADDINS\md5.xlam", False .Item("md5").Installed = true End With If Err = 0 Then MsgBox "надстройка md5 установлена успешно" if not excelapp.visible then excelapp.quit end with
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
А школьники-то как обрадуются... 
