» Excel VBA (часть 3)

Цитата:

А может всё таки лучше с абсолютным типом? как вы думаете? или в моей задаче это без разницы?

Разница есть... в длине кода

Добавлено:
Sniper1, кстати, посмотрел на то, что Вам сделал Maximus777 и увидел у себя шероховатость: лучше переписать Sub subHL, а fncHasHypLnk при этом за ненадобностью удалить
Код: Private Sub subHL(oHLc As Range)
Dim r As Range, c As Range
Set r = Range(oHLc.Offset(-1), oHLc.Offset(1))
For Each c In r.Cells
With c.Font
If c.Hyperlinks.Count > 0 Then
'...
End Sub
'Private Function fncHasHypLnk(c As Range) As Boolean
'On Error Resume Next
'fncHasHypLnk = Not IsEmpty(c.Hyperlinks(1).Address)
'End Function

Цитата:

А может всё таки лучше с абсолютным типом? как вы думаете? или в моей задаче это без разницы?

Подогнал всё как сказали и оставил ячейки с абсолютным типом но оказалось что это для моей таблицы не совсем работает. Заметил такое в C18 при относительной ссылке =СУММ($C$4:$C$16) стало только суммировать столбец C, когда при таком =СУММ(C4:E16) варианте, суммировались столбцы C, D, E. аааа только сейчас заметил, он опять изменил формулу с =СУММ(C4:E16) на =СУММ($C$4:$C$16) ну думаю ок, сам поправил на такое =СУММ($C$4:$E$16) но когда отпускаешь или поднимаешь строки он опять возвращает в такое =СУММ($C$4:$C$16) положение. думаю все таки вставить ваш код который закрепляет к относительным ссылкам. что скажете ув. vlth?

Добавлено:

Цитата:

Sniper1, кстати, посмотрел на то, что Вам сделал Maximus777 и увидел у себя шероховатость: лучше переписать Sub subHL, а fncHasHypLnk при этом за ненадобностью удалить
Код:

Переписал, теперь выходит какая то ошибка, скорей всего не правильно что то переписал наверное. Гляньте


Цитата:

Кстати, принципиальная разница, в том, что сделал Maximus, и в том, что я, следующая:

1. Он выбрал вариант, в котором временная строка для обмена форматами при ротации формируется за пределами таблицы - ниже каких-либо данных на листе. Я решил делать то же самое в пределах таблицы, поэтому мне в конце-концов пришлось бороться с последствиями такого выбора.

2. У меня перемещается строка таблицы, у него - строка листа.
Это менее существенное отличие, чем первое.

3. Есть кое-что ещё, но с точки зрения возможности приведения вариантов к единому знаменателю, это вообще несущественно.
Т.е. в результате способы достижения цели фактически идентичны. При этом и время выполнения кода (замерял грубо - с помощю Timer 'а) не отличается, хотя, по логике, у моего "оппонента" он должен работать быстрее.

Эт мне ёще предстоит в конце выбирать на каком из ваших решений буду работать когда доделаем всё. Замечу что оба решения мне очень нравятся так что будет не легко в выборе

Добавлено:

Цитата:

Переписал, теперь выходит какая то ошибка, скорей всего не правильно что то переписал наверное. Гляньте

Вроде догнал где ошибка, должно быть так?

Код: Private Sub subHL(oHLc As Range)
Dim r As Range, c As Range
Set r = Range(oHLc.Offset(-1), oHLc.Offset(1))
For Each c In r.Cells
With c.Font
If c.Hyperlinks.Count > 0 Then
.ColorIndex = 5
.Underline = xlUnderlineStyleSingle
.Bold = False
Else
.ColorIndex = xlAutomatic
.Underline = xlUnderlineStyleNone
.Bold = True
End If
End With
Next
End Sub
'Private Function fncHasHypLnk(c As Range) As Boolean
'On Error Resume Next
'fncHasHypLnk = Not IsEmpty(c.Hyperlinks(1).Address)
'End Function

Цитата:

Попробовал, но и это не помогает. почему то формула при перебросе строк, всегда меняется для суммирования только одного столбца, когда мне надо все три.

Потому, что я не обратил на формулы особого внимания: обычно суммирование идёт по одному столбцу.
Тогда так #

Добавлено:

Цитата:

Вроде догнал где ошибка, должно быть так?

Точно так )))

Цитата:

Тогда так #

vlth вы наверное скорей всего имели ввиду так? #

Добавлено:
Ув. vlth я тут попробовал всякие действия по поиску недочётов и нашёл несколько, которые бы хотел, что б вы мне подправили.

Берём жертву

1. 5я строка, вводим гиперссылку в имя клиента, видим размер шрифта отличается от гиперссылки 4й строки. хочу что б при вводе гиперссылок в имена клиентов он был такой же как в 4й строке

2. 6ю строку меняем между 5й при помощи нашей комбинации клавиш, видим в 5й строке шрифт увеличился, надо что б оставался как он был до этого. а в 6й строке шрифт стал как мне нужен.

Я полагаю что достаточно исправить первое задание и второе задание уже само исправится.

В модуле ЭтаКнига
Код: Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Hyperlinks.Count > 0 Then Target.Font.Size = 11
End Sub

Цитата:

В модуле ЭтаКнига
Код:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Hyperlinks.Count > 0 Then Target.Font.Size = 11
End Sub

Вроде достаточное решение, спасибо.

Так едем дальше.

Хочу при комбинации клавиш CTRL+SHIFT+R (проверил не занято) что б добавлялась новая строка вниз таблицы, соответственно форматам и заливкам верхних строк. думаю вы поняли о чём я

Цитата:

Цитата:
Они у вас и так там все одного формата. Вот последний вариант. За пределы таблички не "высовывается". Нижняя граница отлавливается по цвету заливки.


Спасибо! вечером гляну, сейчас на работу бежать надо. Насчет последнего варианта вы ошибаетесь мне ещё ваша помощь будет нужна.
Цитата:


Или про строку 4 имелось ввиду что там размер шрифта малость другой?


Ага, они принимают от друг друга размер шрифта а точней жирность его во время обмена строк а этого мне не надо, надо что б они оставались как есть. доделайте плизз.

Maximus777 мне очень понравилась ваша работа со цветом в таблице. доделайте пожалуйста со шрифтами в именах клиентов что б было как вот сделал vlth в этом файле.

Ну и это хочу сразу же попросить

Цитата:

Хочу при комбинации клавиш CTRL+SHIFT+R (проверил не занято) что б добавлялась новая строка вниз таблицы, соответственно форматам и заливкам верхних строк. думаю вы поняли о чём я

Цитата:

Хочу при комбинации клавиш CTRL+SHIFT+R (проверил не занято) что б добавлялась новая строка вниз таблицы, соответственно форматам и заливкам верхних строк. думаю вы поняли о чём я

Из шапки:
Цитата:

Обратите внимание, этот топик для помощи в изучении и использовании VBA. Посему запросы типа "Напишите мне такой-то макрос, я VBA не знаю и знать не хочу" не приветствуются.

Sniper1, попробуйте воспользоваться макрорекордером.
Подскажу, что Вам нужно проверять заливку существующей строки (objВставленнаяСтрока.offset(-1).interior.colorindex) и на основании результата проверки выбирать заливку для новой. Хотя, можно реализовать и вариант Copy-Paste...
В любом случае, примеров для реализации требуемого у Вас теперь предостаточно.
Будут КОНКРЕТНЫЕ вопросы при решении каких-либо задач программирования в Excel - обращайтесь, а прежний формат общения по поводу Вашей таблицы, я считаю, себя исчерпал.

Цитата:

Sniper1, попробуйте воспользоваться макрорекордером.
Подскажу, что Вам нужно проверять заливку существующей строки (objВставленнаяСтрока.offset(-1).interior.colorindex) и на основании результата проверки выбирать заливку для новой. Хотя, можно реализовать и вариант Copy-Paste...
В любом случае, примеров для реализации требуемого у Вас теперь предостаточно.
Будут КОНКРЕТНЫЕ вопросы при решении каких-либо задач программирования в Excel - обращайтесь, а прежний формат общения по поводу Вашей таблицы, я считаю, себя исчерпал.

Пробовал, пробовал, чуть голову не поломал но так и не добившись желаемого результата видать не по моим это зубам.

Перерыл все формулы в Excel но ответа не нашел.

Прошу помощи.

Есть таблица (прайс) товаров (артикул, название и цена) товары в списке могут быть в разных валютах.

На других страницах делаю группировку товаров из прайса:

Код: =ЕСЛИ(ЕОШИБКА(ВПР(A55;Price!$A$2:$D$3500;3;ЛОЖЬ));"звонитне";ВПР(A55;Price!$A$2:$D$3500;3;ЛОЖЬ))

U571, Формат->Условное форматирование... пробовали?

Там я не нашел как копировать с формулой и формат ячейки (код валюты)

Ув. vlth прошу решить мою последнюю задачу, а-то столько было сделано вами и потрачено ваше время, и выходит всё зря. сам я не осилил просто.

Sniper1

Код: Private Sub Workbook_Open()
With Application
...
.OnKey "^+R", "Макрос"
End With
End Sub

U571, Вы таблицы-то свои покажите... Хотя бы фрагменты, но с полным набором используемых валют.

Цитата:

Sniper1

Код:
Private Sub Workbook_Open()
With Application
...
.OnKey "^+R", "Макрос"
End With
End Sub

Код:
Sub Макрос()
Dim intDownRow As Integer, r As Range

Set r = Selection
With Application
.EnableEvents = False
.ScreenUpdating = False
With ActiveSheet
intDownRow = .Columns(1).Rows(.Rows.Count).End(xlUp).Row - 1
Range(.Cells(intDownRow, 1), .Cells(intDownRow, 9)).Insert Shift:=xlDown
With Range(.Cells(intDownRow, 1), .Cells(intDownRow, 9))
.Offset(-2).Copy
.PasteSpecial xlPasteFormats
.Borders(xlEdgeTop).Weight = xlThin
End With
End With
r.Select
.CutCopyMode = False
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

vlth если не затруднит, подправьте ниже перечисленное.

1. При создании первой новой строки, она становится шире всех остальных а все последующие создаваемые строки создаются нормально.

2. При создании первой новой строки, строка над которой она создаётся, сужается. надо что б оставалась как была.

3. В новых строках при их создании в ячейках "H" формула не добавляется.

4. В самой нижней строке где идут подсчеты, формулы не включают в себя подсчет новых создаваемых строк после их создания.

Цитата:

vlth если не затруднит, подправьте ниже перечисленное.

Sniper1, Вы явно перепутали форумы: Вам нужен форум "Работа", а не "Изучение VBA-Excel". Посему либо ищите такой, либо справляйтесь сами. Оставшееся я уже сказал выше.

vlth
+1
Sniper1
Именно поэтому, Вам здесь никто не отвечает. Или обратитесь в Фриланс, или выкладывайте собственные наработки, а мы поможем.

U571, попробуйте это (код нужно расположить в модуле ЭтаКнига):
Код: Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim oCell As Range, strFind As String
Application.ScreenUpdating = False
If Sh.Name <> "Price" And Intersect(Union(Sh.Columns("A:B"), _
Sh.Columns("E:IV")), Target) Is Nothing Then
For Each oCell In Target.Cells
With oCell
If .HasFormula And .Text <> "звонитне" Then
strFind = .Parent.Cells(.Row, 1)
.NumberFormat = Me.Worksheets("Price").Columns(1).Find(strFind) _
.Offset(, 2).NumberFormat
End If
End With
Next oCell
End If
Application.ScreenUpdating = True
End Sub

Цитата:

vlth

БОЛЬШОЕ СПАСИБО! Все работает...

Есть вопрос: "В заголовке формы указать информацию и создать кнопку в форме, по нажатию на которую введенная информация (в строке Caption) вставлялась в ячейку A1 Листа 1 " Может кто подскажет? Очень надо.

Определить, пересечёт ли прямая ax+by+c=0 a)ось 0х, б)ось 0у.
Как решить вроде понятно, но как правильно написать алгоритм без синт. ошибки не понятна по разному пробовал вечно какая нибудь ошибка((( помогите пожалуйста.

randomar
несколько страниц назад же было!

вот полностью рабочий пример:
Sub sdx()
Dim y, x As Variant
y = x = 0
a = InputBox("Введите значение а", _
"значение а")
b = InputBox("Введите значение b", _
"значение b")
c = InputBox("Введите значение c", _
"значение c")
If y = c / b Or x = c / a Then MsgBox ("График пересечет оси координат")
End Sub

RazzieLL
Модуль "ЭтаКнига":

Код: Private Sub Workbook_SheetSelectionChange _
(ByVal Sh As Object, ByVal Target As Range)
Call UpdateBox
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call UpdateBox
End Sub

TimoXa_Skot
СПАСИБО)) век не забуду))))

Господа, добрый день, это снова я. со своими вредными вопросами.Короче встала необходимость, нужно из одной книги скопировать ЗНАЧЕНИЯМИ несколько выборочных листов в другую кнги.
Делаю так: Sheets(Array("1", "2", "3")).Copy
Эта команда создает новую книгу, и копирует туда эти листы, но! Листы копируются с формулами, в итоге все ссылки едут, и значения ломаются.
Пробовал использовать:
With ActiveSheet.UsedRange
.Value = .Value
End With
Но эта команда работает уже после вставки листов, на уже сломанных значениях. Прикрутить её както к процедуре копирования не получилось, чтобы листы изначально копировались значениями. Кто может чем помочь?

Johnson Finger
А если так?
for each sh in wb.sheets
if sh.name=список then
wb2.sheets.add
activesheet.name=sh.name
sh.cells.copy
activesheet.cells.pasteasvalues'синтакис подьерете сами
end if
next

Drazhar - макрос кстати кривоват, сильно допиливать нужно.
Но не в этом дело, в предлагаемом вами решении используется копирование диапазона (который нужно задавать, и он всегда будет фиксированным), мне же нужно копирование целиком листа, с постоянно меняющимися рабочими диапазонами, данными и т.д. Так что спасибо за содействите, но вариант не поможет. От копирования диапазонов я изначально отказался.

Всем привет! Простой вопрос. Как мне вывести текст на форму, чтобы он выводился сразу, а не после щелчка мыши? А потом мне еще его менять нужно будет по ходу выполения программы. Вывожу текст:

Код: Private Sub Label1_Click()
With Label1
.Caption = "Hello!!!"
End With
End Sub

vaulin
так а почему в параметре label не выставить сразу Caption какой нужен...а по ходу меняй уже как вздумается:

With Label1
.Caption = "Hello!!!"
End With