Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » gaz- polutorka
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
Построить график на основе массива, прошу помощи
 
#
25.11.2015 22:28:39
Добрый вечер!

В приложении файл.
Есть 3 параметра, которые являются автоматической выгрузкой из гаджета (шагомера).
Надо или раскидать значения в сттроку по столбцам и построить график на основе этих значений или сразу построить график.
Что по какой оси будет я еще не определился. Поэтому основная задача привести данные в вид для построения графика...
С уважением,
Александр
 
Перейти    
Подбор недостающих значения для получения известного среднего, Формулами или Макросами
 
#
04.03.2015 12:32:03
Уважаемые Дамы и Господа,
Прошу Вас помочь решить не первый взгляд простую задачу.
Затык в следующем.
Есть 3 значения, которые мне известны - это:
1. Минимальное значения ряда данных
2. Максимальное значение ряда данных
3. Среднее значения по ряду данных.
Всего в ряду должно быть 5 чисел.
т.е. мне нужно случайным образом подобрать ещё 3 целых числа и что в сумме все пять чисел с минимальным и максимальным деленые на 5 дали мне мое среднее значения по ряду.
PS: задача нужна для подгонки параметров измерения. Инженер делал 5 измерений, но написал в отчет только мин, макс и среднее (арифметическое). А надо было писать мин, макс, 3 промежуточных значения и среднее.
Спасибо всем за помощь!
Файл с доп объяснялками прилагаю...
С уважением,
Александр
Изменено: gaz- polutorka - 04.03.2015 13:06:26
 
Перейти    
Class Module выдает ошибку на Set, Справка и поиск по форуму не помог :(
 
#
13.01.2013 22:42:16
Помогите разобраться в класс модуле выдает ошибку на строке

Код
Set TboxN = "TXTN" & i


Похоже VBA непонравился значок "&", почему незнаю в справке ненашел

Вот код Класс Модуля
Код
Option Explicit
Public WithEvents oTXTBox As MSForms.TextBox

Private Sub oTXTBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim i As Long
For i = 1 To 62 Step 1
If i <= 31 Then
            If oTXTBox.Name = "TXT" & i Then
                Set Tbox = oTXTBox
                Set TboxN = "TXTN" & i
                Set LboxS = "LBLchg" & i
                Set LboxTotal = "TTLLbl" & (93 + i)
                Set LboxOrder = "Lbl" & (62 + i)
            End If
    Else
            If oTXTBox.Name = "TXTN" & i - 31 Then
                Set Tbox = oTXTBox
                Set TboxN = "TXT" & i
                Set LboxS = "LBLchg" & i
                Set LboxTotal = "TTLLbl" & (93 + i - 31)
                Set LboxOrder = "Lbl" & (62 + i - 31)
            End If
End If
Next i
Form_Choice.Show
End Sub


Вот код Userform
Код
Private Sub UserForm_Activate()
    Dim i As Integer
    For i = 1 To 62
        If i < 31 Or i = 31 Then
                Set aoTXTBox(i).oTXTBox = Me.Controls("TXT" & i)
            Else
                Set aoTXTBox(i).oTXTBox = Me.Controls("TXTN" & i - 31)
        End If
    Next i
End Sub


Вот код Модуля
Код
Public Tbox As Object
Public TboxN As Object
Public LboxS As Object
Public LboxTotal As Object
Public LboxOrder As Object
Public aoTXTBox(1 To 62) As New clsmFrmTabelTXT
Option Private Module
 
Перейти    
[ Закрыто] Макрос сохраняющий данные в таблицу на лист собирает данные из Userform, Требуется помощь в оптимизации для ускорения. Работает из рук вон медленно.
 
#
08.01.2013 22:36:56
Уважаемые Форумчане,
В моем проекте есть макрос, который сохраняет данные на лист собирая их с Userform и с другого рабочего листа.

Так вот этот макрос работает действительно медленно, хотя мне кажется что написан не очень сложно.
Подскажите пожалуйста где ошибка? какие операции тормозят и что заменить чтоб ускорить.
Как оптимизировать?

Вид ФОРМЫ в приложении. Файл готовый великоват и мне кажется ни к чему. Но если кому надо для решения задачи я готов сбросить. Никаких супер секретов в нем нет.

Код
Public SaveTotal As Object
Public SaveChange As Object
Private Sub B_SaveFAG_Click() 'макрос выполняет все необходимые проверки и сохраняет данные в БД
Application.ScreenUpdating = False
'SU - это лист где производятся расчеты
'DB - это лист куда сохраняются данные
Dim ro As Range, lo As Long, li As Long, Guy, Job
Guy = SU.Range("B1").Value ' эта переменная за собой имеет значение числа (не текст типа ФИО)
Job = SU.Range("AJ3").Value ' эта переменная за собой имеет тоже значение простого числа
lo = 0
    For li = 94 To 124
        lo = lo + 1
        Set SaveTotal = Form_Tabel.Controls("TTLLbl" & li)
        Set SaveChange = Form_Tabel.Controls("LBLchg" & lo)
        If SaveChange.Caption = "" Then
            li = li + 0
        Else
               If IsNumeric(SaveTotal.Caption) = True Then
                   If IsNumeric(SaveChange.Caption) = False Then
                   Set ro = DB.Range("a" & DB.Rows.Count).End(xlUp).Offset(1).EntireRow
                        ro.Cells(1) = Guy
                        ro.Cells(2) = Job
         ro.Cells(3) = CDate(lo & "." & SU.Range("C2").Value & "." & SU.Range("B3").Value)
                        ro.Cells(4) = Form_Tabel.Controls("TXT" & lo)
                        ro.Cells(5) = Form_Tabel.Controls("TXTN" & lo)
                   Else
                   Set ro = DB.Range("a" & DB.Rows.Count).End(xlUp).Offset(1).EntireRow
                        ro.Cells(1) = Guy
                        ro.Cells(2) = Job
         ro.Cells(3) = CDate(lo & "." & SU.Range("C2").Value & "." & SU.Range("B3").Value)
                        ro.Cells(4) = Val(Form_Tabel.Controls("TXT" & lo))
                        ro.Cells(5) = Val(Form_Tabel.Controls("TXTN" & lo))
                   End If
               Else
                   If IsNumeric(SaveChange.Caption) = True Then
                       For la = 2 To Лист_Orders.Range("F1").Value + 1
                      Set ro = DB.Range("a" & DB.Rows.Count).End(xlUp).Offset(1).EntireRow
                           ro.Cells(1) = Guy
                           ro.Cells(2) = Лист_Orders.Range("b" & la).Value
         ro.Cells(3) = CDate(lo & "." & SU.Range("C2").Value & "." & SU.Range("B3").Value)
                           ro.Cells(4) = Val(0)
                           ro.Cells(5) = Val(0)
                       Next la
                      Set ro = DB.Range("a" & DB.Rows.Count).End(xlUp).Offset(1).EntireRow
                           ro.Cells(1) = Guy
                           ro.Cells(2) = Job
         ro.Cells(3) = CDate(lo & "." & SU.Range("C2").Value & "." & SU.Range("B3").Value)
                           ro.Cells(4) = Val(Form_Tabel.Controls("TXT" & lo))
                           ro.Cells(5) = Val(Form_Tabel.Controls("TXTN" & lo))
                   Else
                  Set ro = DB.Range("a" & DB.Rows.Count).End(xlUp).Offset(1).EntireRow
                       ro.Cells(1) = Guy
                       ro.Cells(2) = Job
         ro.Cells(3) = CDate(lo & "." & SU.Range("C2").Value & "." & SU.Range("B3").Value)
                       ro.Cells(4) = Form_Tabel.Controls("TXT" & lo)
                       ro.Cells(5) = Form_Tabel.Controls("TXTN" & lo)
                   End If
               End If
        End If
    Next li
Application.ScreenUpdating = True
End Sub


Вид ФОРМЫ в приложении.

С уважением,
Александр
 
Перейти    
Форматировать ячейки макросом, Группировка, линии, заливки
 
#
03.01.2013 21:10:35
Уважаемые Форумчане,

Прошу помочь решить задачу.

В приложении файл с тем что есть и что надо получить.

Суть привести выгрузку из базы данных к читаемому виду.
К сожалению несмог найти ни на старом ни на новом форуме решения задачи как объединить ячейки с ФИО до следующей ФИО.

Перекрасить ячейки дело не такое хитрое, но всё же может кто-то поможет решить задачу комплексно.

С уважением,
Александр
 
Перейти    
Combobox с условием заполнения и по алфавиту, по алфавиту подглядел в старом форуме у турбоежа вроде, а вот с условием проблема
 
#
25.12.2012 23:54:23
Уважаемые Форумчане,

Требуется исходя из значения столбика B, заполните Combobox на Userform, значениями из столбика, и желательно сразу отсортировать по алфавиту.

В приложении файл, всё необходимое подготовил.
Кто может, помогите пожалуйста.

С уважением,
 
Перейти    
Выбор значений из массива, требуется формула.
 
#
16.12.2012 18:26:03
Уважаемые Форумчане,  
 
В приложении пример со всеми вопросами и примерами, прошу помощи.  
 
Я честно пробовал искать по форуму и даже какие то части задачи выполнить смог, но комплексную задачу, учитывающую все условия так и не решил.  
 
Я перепробовал в различных комбинациях функции массивов (ctrl shift enter) типа;  
ИНДЕКС, ПОИСКПОЗ, НАИМЕНЬШИЙ, НАИБОЛЬШИЙ, СТРОКА, и т.п...  
 
Знаний не хватило...  
 
Сразу скажу что я использую офис 2007.  
 
С уважением,  
Александр
 
Перейти    
ID Контектного меню
 
#
06.05.2011 10:35:37
Уважаемые Форумчане,  
 
Прошу помощи с подборкой ID к Контекстному меню Pivot Table.  
 
Я перебрал все ID касательно Pivot Table с сайта Microsoft но то что надо не нашел.  
( http://support.microsoft.com/kb/213552/EN-US/ )  
 
Может быть кто знает как искать более грамотно или просто знает нужный ID.  
Может быть ссылку на сайт с ID где более широкий выбор (у меня EXCEL 2010).  
 
В приложении обвел маркером желтым те 4 пункта контекстного меню которые надо.  
 
Код в VBA куда вписываю ID нашел здесь на сайте. Вот он:  
 
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)  
  On Error Resume Next  
   Dim ivIDArray, li As Long: ivIDArray = Array(19, 462, 464) ' В этих скобках нужный ID  
With Application.CommandBars.Add(, msoBarPopup, False, True)  
       For li = LBound(ivIDArray) To UBound(ivIDArray)  
           .Controls.Add(ID:=ivIDArray(li)).Visible = True:  
       Next li  
       .ShowPopup: Cancel = True  
   End With  
End Sub  
 
С уважением,  
Александр
 
Перейти    
Хочу оптимизировать макрос
 
#
21.04.2011 09:55:48
Уважаемый Дамы и Господа,  
 
Помогите пожалуйста оптимизировать макрос.  
 
Таких макросов целая линейка.  
Причем Case'ов разное количество в каждом и параметр PMZ меняется.  
При каждом Case параметр A в значении For всегда увеличивается на 11 в зависимости от того, значения которое стоит в CAse 0.  
 
К примеру Если Case 0, Параметру A присвоены значения For A 10 to 65,  
то в Case 1 параметру A будут присвоены параметры For A 10+11=21 to 65  
 
Надеюсь что задачу ясно объяснил.  
Думаю что файл выкладывать не надо.  
 
Макросы запускаются при изменении значения в определенной ячейке.  
Для каждой ячейки свой макрос.  
 
'''''''''''''''''''''''''''''''''МАКРОС 1'''''''''''''''''''''''''''''''''  
 
Public Sub Pesok1Hidden()  
Application.ScreenUpdating = False  
Dim A As Long, B As Long, PMZ  
PMZ = Cells(240, 3).Value  
Select Case PMZ  
Case 0  
For A = 243 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 1  
For A = 254 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 2  
For A = 265 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 3  
For A = 276 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 4  
For A = 287 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 5  
For A = 298 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 6  
For A = 309 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 7  
For A = 320 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 8  
For A = 331 To 331 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 9  
End Select  
End Sub  
 
'''''''''''''''''''''''''''''''''МАКРОС 2'''''''''''''''''''''''''''''''''  
 
Public Sub Brigadier1Hidden()  
Application.ScreenUpdating = False  
Dim A As Long, B As Long, PMZ  
PMZ = Cells(189, 3).Value  
Select Case PMZ  
Case 0  
For A = 192 To 225 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 1  
For A = 203 To 225 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 2  
For A = 214 To 225 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 3  
For A = 225 To 225 Step 11: B = A + 9: Range("E" & (A) & ":" & "AI" & (B)).ClearContents: Range("B" & (A) & ":" & "B" & (B)).ClearContents: Next A  
Case 4  
End Select  
End Sub
 
Перейти    
Контекстное меню, Скрестить стандартное и собственное
 
#
19.04.2011 19:11:10
Уважаемые Форумчане,  
 
В приложении файлик.  
 
В файлике скрестил 2 способа, которые нашел на форуме. Первый взял у The Prist, это способ, который через стандартные функции ID элементов оставляет в меню при нажатии правой кнопки мыши только то, что надо.  
И второй ещё нашел не помню у кого, вроде Hugo и Муля. В котором добавление в меню происходит при открытии функции со значком и удалении при закрытии книги.  
 
Так вот мне надо что-то среднее. Т.е. с одной стороны оставить стандартные функции, которые и так уже были и есть в Excel, но и при этом добавить свою.  
 
Через MsgBox выяснил что новой функции excel присвоил ID = 1, но при подстановке в код the Prist он его не считывает, а просто оставляет пустое место.  
 
При этом если закоментировать код по правому щелчку мыши, то добавленная функция в контекстном меню появиться.  
 
Помогите пожалуйста, очень надо=)))  
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
Перейти    
Userform с Макросом для Обновление Ссылок формул на др.книгу
 
#
13.01.2011 11:19:33
Уважаемый Дамы и Господа,  
 
Честно порыл форум, приемы и по-yandex-ил и по-google-ил, но так и не смог найти ничего по моей теме полезного.  
 
Вообщем прошу помочь со следующей задачей.  
 
При запуске файла (книги Excel 2007), всплывает Userform, который спрашивает обновить ссылки на др. книги или нет.  
Если нет, то Userform выгружается и ссылки не обновляются.  
Если да, то всплывает стандартное окно на обновление ссылок, там пользователь указывает путь к новому файлу с которого будут браться данные и жмет обновить, книга пересчитывается.  
 
В приложенном файле приготовил Стартовую Userform и в Code Userform прописал подробнее что надо сделать.  
На листе 2 сделал Printscreen стандартного способа указания на обновления ссылок, чтоб было понятно что я имею ввиду.  
 
Надеюсь на Вашу помощь!  
 
С уважением,  
Александр  
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
Перейти    
Worksheet_Change(ByVal Target As Range), не желает сотрудничать!
 
#
03.01.2011 03:13:55
Уважаемый Дамы и Господа,  
 
Имеется вот такой вот Макрос, вставленный разумеется в коде листа.  
 
 
Private Sub Worksheet_Change(ByVal Target As Range)  
Application.ScreenUpdating = False  
Лист7.Unprotect ("")  
   'ПЕРВЫЙ ЗАКАЗ  
   Dim rng1 As Range: Set rng1 = [C8:D8]
   If Not Intersect(rng1, Target) Is Nothing Then  
   Module1.Hidden1  
   Module3.Hidden1  
End If  
   'ВТОРОЙ ЗАКАЗ  
   Dim rng2 As Range: Set rng2 = [C9:D9]
   If Not Intersect(rng2, Target) Is Nothing Then  
   Module1.Hidden2  
   Module3.Hidden2  
End If  
   'ТРЕТИЙ ЗАКАЗ  
   Dim rng3 As Range: Set rng3 = [C10:D10]
   If Not Intersect(rng3, Target) Is Nothing Then  
   Module1.Hidden3  
   Module3.Hidden3  
         
       'КОЛИЧЕСТВО МАСТЕРОВ  
       Dim rng11 As Range: Set rng11 = [C21:C21]
       If Not Intersect(rng11, Target) Is Nothing Then Module2.Master1Hidden  
     
       'КОЛИЧЕСТВО СМЕННЫХ МАСТЕРОВ  
       Dim rng12 As Range: Set rng12 = [C72:C72]
       If Not Intersect(rng12, Target) Is Nothing Then Module2.Master2Hidden  
     
       'КОЛИЧЕСТВО БРИГАДИРОВ  
       Dim rng13 As Range: Set rng13 = [C189:C189]
       If Not Intersect(rng13, Target) Is Nothing Then Module2.Brigadier1Hidden  
     
If Intersect(Target, Range("E24:AI3924")) Is Nothing Then Exit Sub  
If WorksheetFunction.Sum(Range(Target.Address)) > 0 Then Exit Sub  
 
Лист7.Range(Target.Address).Value = Range(Target.Address).Value  
Лист7.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, Password:=""  
End Sub  
 
 
Надо добавить к нему вот такую гадость:  
 
'If Target Is Nothing Then Exit Sub  
'If Range("AZ34").Value = "0" Then Exit Sub  
'If Range("AZ34").Value = (ЛОЖЬ) Then  
'   MsgBox "ОШИБКА ВВОДА ДАННЫХ", vbCritical, "ООО ''Рога и Копыта''"  
'   Target = ""  
'   Target.Select  
'End If  
 
Куда бы не вставлял и как бы не крутил, то Exit Sub у первоначального рано срабатывает, то MsgBox из гадости заклинивает и он его по кругу пускает.  
 
Помогите совокупить два кода=))  
 
Заранее спасибо!    
 
С уважением,  
Александр
 
Перейти    
Ограничение ввода значений в ячейки списка
 
#
01.01.2011 12:34:15
Уважаемый Дамы и Господа,  
Прежде всего поздравляю Вас с Новым Годом!  
 
Требуется помощь специалистов!  
В файле все пояснения, кратко изложить суть вопроса не смог.  
 
Задача на первый взгляд не сложная, но у меня что-то никак не получается.  
 
С уважением,  
Александр
 
Перейти    
Массив. Формирование списка сотрудников по списку данных.
 
#
27.12.2010 01:02:02
Уважаемые Дамы и Господа,  
 
Прошу помощи! Прикладываю файл, там в принципе всё понятно что надо сделать. Сам перепробовал море вариантов, но умений и соображалки нехватает.  
 
Есть список сотрудников, который приходит из другого файла в столбик "B".  
Этот список содержит как ФИО, так и значения 0 в случае если с того листа откуда ссылка значение нет.  
 
Ну так вот хочу сделать так, чтоб он на том же или отдельном листе формировал этот же список по порядка убирая проклятые нули.  
 
Можно конечно просто фильтром, но у меня дальше будут подвязаны всякие формулы-фигормулы и    
хотелось бы чтоб вот именно через массив это дело сформировалось, ну или каким другим способом только не фильтром.  
 
С уважением,  
Александр
 
Перейти    
Запуск макроса при группировки ячеек
 
#
16.11.2010 13:15:24
Уважаемые Дамы и Господа,  
 
Появилась некоторая проблема.  
Я использую Excel 2007. но надеюсь что в 2003 так же организована группировка.  
На листе есть сгруппированные столбцы, которые при нажатии на тире в квадратике скрываются, а при нажатии на плюсик в скрытом состоянии, соответственно открываеются.  
 
Для моего файла требуется чтобы при нажатии на крестик или тире запускался макрос.  
Как подвязать клик на группировку к макросу.  
 
Я знаю что можно подвязать клик для группировки уровня, следующей строкой кода:  
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2  
 
Но в случае если в уровни группироыки несколько рестиков и я щелкаю подному из них, то макрос естественно не срабатывает.  
 
Макрос будет что-то типа If Columns("J:L").EntireColumn.Hidden = True Then Range("M1").Formula = "1" Else Range("M1").Formula = "0"  
 
Надеюсь что объяснил понятно.  
Если нужен файл то могу приложить, но тут особо то и прикладывать мне кажется нечего.  
 
С уважением,  
Александр
 
Перейти    
Проблема с ProgressBar к конкретному макросу
 
#
03.03.2010 12:19:46
Уважаемые Господа,  
 
Плохо разбираюсь в VBA и незнаю как добавить ProgressBar к макросу, код которого привожу ниже.  
 
Макрос выполняет подмену гиперссылок, при изменении имени листа и нужен именно в таком виде как есть.    
 
Хотелось бы чтоб по ходу выполнения макроса по центру экрана появлялась форма которая показывала бы состояние выполнения сего действа.  
 
Я поискал на форуме похожие темы и их много, но применить к макросу неполучается.    
 
Помогите пожалуйста, в идеале дайте файл с прогрессбаром и этим макросом и формой.  
 
 
 
 
 
 
 
 
Sub МакросПодменыГиперов()  
 
 
' Подмена  
 
 
 
   Range("C18").Select  
   Selection.Hyperlinks(1).SubAddress = "B154"  
   Range("C19").Select  
   Selection.Hyperlinks(1).SubAddress = "B191"  
   Range("C20").Select  
   Selection.Hyperlinks(1).SubAddress = "B228"  
   Range("C21").Select  
   Selection.Hyperlinks(1).SubAddress = "B265"  
   Range("C22").Select  
   Selection.Hyperlinks(1).SubAddress = "B302"  
   Range("C23").Select  
   Selection.Hyperlinks(1).SubAddress = "B339"  
   Range("C24").Select  
   Selection.Hyperlinks(1).SubAddress = "B376"  
   Range("C25").Select  
   Selection.Hyperlinks(1).SubAddress = "B413"  
   Range("C26").Select  
   Selection.Hyperlinks(1).SubAddress = "B450"  
   Range("C27").Select  
   Selection.Hyperlinks(1).SubAddress = "B487"  
   Range("C28").Select  
   Selection.Hyperlinks(1).SubAddress = "B524"  
   Range("C29").Select  
   Selection.Hyperlinks(1).SubAddress = "B561"  
   Range("C30").Select  
   Selection.Hyperlinks(1).SubAddress = "B598"  
   Range("C31").Select  
   Selection.Hyperlinks(1).SubAddress = "B635"  
   Range("C32").Select  
   Selection.Hyperlinks(1).SubAddress = "B672"  
   Range("C33").Select  
   Selection.Hyperlinks(1).SubAddress = "B709"  
   Range("C34").Select  
   Selection.Hyperlinks(1).SubAddress = "B746"  
   Range("C35").Select  
   Selection.Hyperlinks(1).SubAddress = "B783"  
 
 
' Подмена основных  
 
   Range("B126:C127").Select  
   ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _  
       "B16", TextToDisplay:="      Перейти по ссылке…                    "  
   Selection.Font.Size = 11  
   Selection.Font.Underline = xlUnderlineStyleNone  
   With Selection.Font  
       .ColorIndex = xlAutomatic  
       .TintAndShade = 0  
   End With  
   Selection.Font.Bold = True  
   Selection.Font.Size = 14  
 
   Range("A125:C128").Select  
   Selection.Copy  
   ActiveWindow.SmallScroll Down:=15  
   Range("A162").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=36  
   Range("A199").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=39  
   Range("A236").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=39  
   Range("A273").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=39  
   Range("A310").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=33  
   Range("A347").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=39  
   Range("A384").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=33  
   Range("A421").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=36  
   Range("A458").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=36  
   Range("A495").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=36  
   Range("A532").Select  
   ActiveSheet.Paste  
   ActiveWindow.SmallScroll Down:=39  
   Range("A569").Select  
   ActiveSheet.Paste  
   Range("B1").Select  
     
   End Sub
 
Перейти    
Страницы: 1
Наверх