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
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
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
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
вместо -9 написать -99 и, соответственно, вместо G4:G99 указать диапазон, охватывающий все данные и формулу лучше переписать так, ибо, если будут дробные числа будет работать неверно
вместо -9 написать -99 и, соответственно, вместо G4:G99 указать диапазон, охватывающий все данные и формулу лучше переписать так, ибо, если будут дробные числа будет работать неверно
Видимо собака зарылась в разнице версий Excel, у меня сейчас под рукой только 2007 именно поэтому тут написано
Цитата
Старайтесь прилагать файлы в версии Excel 2003-го офиса(xls), так как эти файлы могут открыть пользователи с любой версией Excel, в отличие от файлов версий Excel 2007/2010/2013 (xlsх).
При открытии в E3 проверки данных нет, скрин делать лень. Нашел диапазон на скрытом листе, в 2007 не поддерживаются источники для проверки данных с другого листа напрямую исправил макрос во 2 посте
второй вариант макроса[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 Application.Run "Лист1.Макрос_" & UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) End If End Sub
[/vba]
Видимо собака зарылась в разнице версий Excel, у меня сейчас под рукой только 2007 именно поэтому тут написано
Цитата
Старайтесь прилагать файлы в версии Excel 2003-го офиса(xls), так как эти файлы могут открыть пользователи с любой версией Excel, в отличие от файлов версий Excel 2007/2010/2013 (xlsх).
При открытии в E3 проверки данных нет, скрин делать лень. Нашел диапазон на скрытом листе, в 2007 не поддерживаются источники для проверки данных с другого листа напрямую исправил макрос во 2 посте
второй вариант макроса[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 Application.Run "Лист1.Макрос_" & UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) End If End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
