» Excel VBA (часть 3)

Цитата:

Попробуем и такое чудо сотворить.

Спасибо!, я знал что вы меня в беде не бросите.


Цитата:

Цитата:
чуть чуть не подходит ваш вариант. таблица не статическая, строки будут добавляться иногда или даже удаляться

Sniper1, проблемы реализовать работу процедур с динамически меняющейся таблицей нет, нужна лишь информация, как она будет меняться, которую Вы не представили.

Я и не сомневаюсь что для вас не какой проблемы не составит это всё реализовать, всё дело во мне, я не так объяснил всё с самого начала. Не много расскажу про таблицы, файлов будет примерно 50 и в каждом файле будет эта таблица но с разным количеством клиентов начиная от 1 и заканчивая скажем 200.


Цитата:

Цитата:
А если надо с форматом перемещать?

vchobo, этот вариант был представлен в обсуждении выше. Sniper1 его отверг как не отвечающий его задачам.

Я его не отверг, он у меня хранится на всякий случай, про запас так сказать. Хотя он у меня вроде не сработал по клавишам "CTRL+SHIFT+стрелка вверх или вниз", наверное я не так его присобачил в таблицу. Кстати в этом вашем решение я заметил хорошую штуку, то что когда двигаешь строки и если доходя до конца таблицы сверху или внизу то оно не даёт зашкалить за неё. надо будет попросить об этом Maximus777 что б позаботился и об этом в своём решение.

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

Цитата:

файлов будет примерно 50 и в каждом файле будет эта таблица но с разным количеством клиентов начиная от 1 и заканчивая скажем 200

Sniper1, т.е. таблицы будут различаться только количеством клиентов, я правильно понял?

Цитата:

Цитата:
файлов будет примерно 50 и в каждом файле будет эта таблица но с разным количеством клиентов начиная от 1 и заканчивая скажем 200

Sniper1, т.е. таблицы будут различаться только количеством клиентов, я правильно понял?

Пока думаю что да, может когда нибудь потом ещё надумаю чего а может и не надумаю.

Sniper1, ещё вопрос: кроме этих таблиц на листах под- и над ними будет какая-либо информация (это нужно знать, чтобы определять границы таблиц)?

Цитата:

Sniper1, ещё вопрос: кроме этих таблиц на листах под- и над ними будет какая-либо информация (это нужно знать, чтобы определять границы таблиц)?

Ну пока что не каких планов нету на этот счет. кстати там в таблицах в столбе "F4" и по "F104" у меня макрос на них стоит, если туда что то вводится то выскакивает окошко для ввода номера кассы в "G" я это оставил на случай если таблица будет расти при добавление клиентов. но это вроде вам не будет мешать, я так понимаю.

Цитата:

и если доходя до конца таблицы сверху или внизу то оно не даёт зашкалить за неё

If ActiveCell.Row > 1 Это и есть проверка на выход выше первой строки. Насчёт нижней границы можно не беспокоиться. У вас же не будет 65535 строк на листе?

Если же вам надо двигать только в пределах таблички, то можно просто условие задать. Отлавливать движение за табличку по каким-то статичным ячейкам.

Много раз читал об отмене действий макросов, и всегда находил одно и тоже:
- Сохраните книгу, перед действием макроса, если что то не так
- Закройте без сохранения
- Заново откройте

Скрипт заставляет excel тормозить при выполнении макроса, что не радует...реализовал для себя может пригодится кому!
------------------------------------------------------------------------------------------------------
Sub comandarall() 'Рopup меню для всего листа
Dim mBar As CommandBar
Set mBar = CommandBars("cell")
mBar.Reset
If Is_sheet_exist("Титул (2)", ActiveWorkbook, xlWorksheet) Then
x = "Отменить действие макроса"
mBar.Controls.Add(Type:=msoControlButton, Before:=1).Caption = x
mBar.Controls(x).FaceId = 868
mBar.Controls(x).OnAction = "back"
End If
End Sub
------------------------------------------------------------------------------------------------------
Sub save() 'Функция сохранения _
(выполняется перед макросами)

Application.DisplayAlerts = False
If Is_sheet_exist("Титул (2)", ActiveWorkbook, xlWorksheet) Then
Sheets("Титул (2)").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Титул").Select
Sheets("Титул").Copy Before:=Sheets(5)
Else
Sheets("Титул").Select
Sheets("Титул").Copy Before:=Sheets(5)
End If
Application.DisplayAlerts = True
Sheets("Титул").Select
End Sub
------------------------------------------------------------------------------------------------------
Sub back() 'Функция отмены действия макроса
Application.DisplayAlerts = False
If Is_sheet_exist("Титул (2)", ActiveWorkbook, xlWorksheet) Then
Sheets("Титул").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Титул (2)").name = "Титул"
Sheets("Титул").Select
Sheets("Титул").Move Before:=Sheets(1)
End If
Application.DisplayAlerts = True
End Sub
------------------------------------------------------------------------------------------------------
Function Is_sheet_exist(Sheet_name As String, book As Workbook, Worksheet_type As Long) As Boolean
' Функция проверки листа на существование

Dim current_sheet As Worksheet
Is_sheet_exist = True
For Each current_sheet In book.Worksheets
If current_sheet.name = Sheet_name And current_sheet.Type = Worksheet_type Then Exit Function
Next current_sheet

Is_sheet_exist = False
End Function
------------------------------------------------------------------------------------------------------
В итоге получилось быстрое создание резервной копии листа "титул" с возможности вернуть предыдущие состояние по горячей клавише в контекстном меню листа. Замечу что данный метод не заметен при работе (имеется в виду задержки при выполнении макросов).

Цитата:

If ActiveCell.Row > 1 Это и есть проверка на выход выше первой строки. Насчёт нижней границы можно не беспокоиться. У вас же не будет 65535 строк на листе?

Не вы не так поняли меня. мне надо что б не заходило за пределы строк "4" и "16".


Цитата:

Если же вам надо двигать только в пределах таблички, то можно просто условие задать. Отлавливать движение за табличку по каким-то статичным ячейкам.

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

Цитата:

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

Значит, в функцию смещения строк, надо добавить отлов границ. У меня Офис 2003. То ли он не понимает ваш файл, то ли он у вас не на русском языке, вобщем выглядит вот так:


Ячейку, по которой предлагаю отлавливать низ таблички, я выделил. Хз чего там у вас в оригинале написано, но если этот текст не меняется, то вот вам и решение. В коде я написал EndTable. Замените его на свой текст.

Код: Public Sub Auto_Open() 'Назначаем горячие клавиши
Application.OnKey "+^{UP}", "RowUp" 'Shift+Ctrl+Вверх
Application.OnKey "+^{DOWN}", "RowDown" 'Shift+Ctrl+Вниз
End Sub

Sub Mov(r As Long, dr As Integer) 'Аргументы: Строка, Направление
r1 = r + 1 * dr
Dim tmp As Range
With Rows(r).Worksheet.UsedRange
Set tmp = .Rows(.Rows.Count).Offset(1).EntireRow
End With
Rows(r).EntireRow.Copy tmp
Rows(r1).Copy Rows(r)
tmp.Copy Rows(r1)
Rows(r).EntireRow.Copy
tmp.PasteSpecial xlPasteFormats
Rows(r1).Copy
Rows(r).PasteSpecial xlPasteFormats
tmp.Copy
Rows(r1).PasteSpecial xlPasteFormats
tmp.Delete
Call Link(Cells(r, 1), Cells(r, 1).Hyperlinks.Count)
Call Link(Cells(r1, 1), Cells(r1, 1).Hyperlinks.Count)
Rows(r1).Select
End Sub

Sub Link(r As Range, s As Variant) 'Аргументы: Ячейка, Стиль
With r.Font
If s = 0 Then
.ColorIndex = 0
.Underline = False
Else
.ColorIndex = 5
.Underline = True
End If
End With
End Sub

Sub RowUp()
If ActiveCell.Row > 4 Then Call Mov(ActiveCell.Row, -1)
End Sub

Sub RowDown()
For i = 4 To 100
If Cells(i, 1) = "EndTable" Then n = i - 1: Exit For
Next i
If ActiveCell.Row < n Then Call Mov(ActiveCell.Row, 1)
End Sub

Sniper1

Код: Private Sub Workbook_Open()
'остаётся прежний код
End Sub

Sub prcRowUp()
prcMoveRow False
End Sub
Sub prcRowDown()
prcMoveRow True
End Sub

Sub prcMoveRow(blnDown As Boolean)
Dim oRow As Range, oTable As Range, oCell As Range
Dim intLClientRow As Integer, intOf As Integer

intOf = blnDown * 2 + 1
With ActiveSheet
intLClientRow = .Columns(1).Rows(.Rows.Count).End(xlUp).Row - 2
Set oTable = Range(.Cells(4, 1), .Cells(intLClientRow, 9))
End With
Set oCell = ActiveCell
With Application
.EnableEvents = False
.ScreenUpdating = False
With oTable
If Not Intersect(oCell, oTable) Is Nothing Then
Set oRow = Intersect(oTable, oCell.EntireRow)
With oRow
If (.EntireRow.Row < oTable.Rows(intLClientRow - 3).EntireRow.Row And blnDown) _
Or (.EntireRow.Row > oTable.Rows(1).EntireRow.Row And Not blnDown) Then
.Cut
.Offset(Abs(blnDown) * 3 - 1).Insert
.Offset(blnDown + 1).Insert Shift:=xlDown
.Copy
.Offset(intOf).PasteSpecial xlPasteFormats
.Offset(2 * intOf).Copy
.PasteSpecial xlPasteFormats
.Offset(intOf).Copy
.Offset(2 * intOf).PasteSpecial xlPasteFormats
.Offset(intOf).Delete Shift:=xlUp
End If
End With
End If
End With
oCell.Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

vlth,
ждём госприёмку, Снипера

Maximus777, о да: это серьёзно

Цитата:

Ячейку, по которой предлагаю отлавливать низ таблички, я выделил. Хз чего там у вас в оригинале написано, но если этот текст не меняется, то вот вам и решение. В коде я написал EndTable. Замените его на свой текст.

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


Цитата:

Sniper1

Код:

Так, попробовал ваш код и в нём действительно не даёт проскочить за рамки. вот тока почему то не фурычит у меня с вашим кодом по клавишам "CTRL+SHIFT+стрелка вверх или вниз", так должно быть или есть какая то ошибочка? в коде от Maximus777 эта функция работает.

Добавлено:

Цитата:

vlth,
ждём госприёмку, Снипера

Цитата:

Maximus777, о да: это серьёзно

Ну думаю это ещё рановато но думаю долго не придется ждать.

Цитата:

... почему то не фурычит у меня с вашим кодом по клавишам "CTRL+SHIFT+стрелка вверх или вниз", так должно быть или есть какая то ошибочка? в коде от Maximus777 эта функция работает.

Sniper1, это очередной тест на Вашу внимательность :

Код: Private Sub Workbook_Open()
'остаётся прежний код
End Sub

Цитата:

Цитата:
... почему то не фурычит у меня с вашим кодом по клавишам "CTRL+SHIFT+стрелка вверх или вниз", так должно быть или есть какая то ошибочка? в коде от Maximus777 эта функция работает.

Sniper1, это очередной тест на Вашу внимательность :

Код:
Private Sub Workbook_Open()
'остаётся прежний код
End Sub
У нас с Maximus777 разные названия процедур (RowUp и prcRowUp, например).
Поскольку сочетание клавиш одно, Вам их нужно переназначать. Или комментить один код во время использования другого (это если Вы назовёте наши процедуры одинаково).

Вот именно ув. vlth что у меня два разных файла один в котором я провожу эксперименты с вашим кодом а другой для кодов ув. Maximus777

Вот посмотрите сами правильно ли я делаю или у меня руки может быть кривые, что совершенно не отрицаю
#

Sniper1, файлы разные, а сочетание клавиш - ОДНО! Метод Applicaton.OnKey назначает клавишам процедуры в пределах ВСЕЙ Excel. Т.е. клавиши, как я уже говорил, для использования другого кода, нужно переназначать. Или открывать книги в разных экземплярах Excel. Или дать процедурам одинаковые названия, но при этом комментить в данный момент неиспользуемые.
Проще всего закрыть книгу "Maximus777", и только после этого открыть книгу "vlth".

Цитата:

Метод Applicaton.OnKey назначает клавишам процедуры в пределах ВСЕЙ Excel.

Ага, есть такое. Тут надо аккуратнее действовать.

Цитата:

Проще всего закрыть книгу "Maximus777", и только после этого открыть книгу "vlth".

Самое быстрое и точное решение.

Цитата:

может можно вместо этого привязать к цветности заливки?

Без проблем. Особливо если её (заливку) сделать поуникальнее.

А ещё можно комментарий к ячейке добавить и делать отлов через него.

Цитата:

Проще всего закрыть книгу "Maximus777", и только после этого открыть книгу "vlth".

Так я так и делаю а попробуйте у себя открыть этот файл и посмотрите у вас это сработает?

Добавлено:

Цитата:

Цитата:
может можно вместо этого привязать к цветности заливки?

Без проблем. Особливо если её (заливку) сделать поуникальнее.

Поуникальнее это как? я всегда за, так как знаю плохого не посоветуете.


Цитата:

А ещё можно комментарий к ячейке добавить и делать отлов через него.

Думаю лучше к заливке привязать, не хочу что б лишние комменты в глаза бросались.

Цитата:

Так я так и делаю а попробуйте у себя открыть этот файл и посмотрите у вас это сработает?

Sniper1, процедуру
Код: Private Sub Workbook_Open()
'остаётся прежний код
End Sub

Цитата:

Цитата:
Так я так и делаю а попробуйте у себя открыть этот файл и посмотрите у вас это сработает?

Sniper1, процедуру
Код:
Private Sub Workbook_Open()
'остаётся прежний код
End Sub
нужно вставить в модуль ЭтаКнига
(Workbook_Open - событие книги, наступающее при её открытии. Соответственно, именно тогда выполняется код, расположенный в процедуре обработки этого события.)

Так вот где мои ручонки кривые были . Я вижу вы ещё не работали над гиперссылками.

Заметил ещё такое что в вашем решение передвижение строк происходит более плавно (почти совсем не заметно) чем в решение Maximus777, в решение Maximus777 таблица вся аж дрыгается, кто из вас знает почему так?

Maximus777 жду вашей доработки с привязкой к заливке конца таблицы.

Цитата:

Я вижу вы ещё не работали над гиперссылками.

Гиперссылки перемещаются. проверьте внимательно (не перемещается только "синий" формат отображения ссылки. Пропишете все гиперссылки - формат ячеек, их содержащих, станет везде одним, "синим").

Цитата:

Цитата:
Я вижу вы ещё не работали над гиперссылками.

Гиперссылки перемещаются. проверьте внимательно (не перемещается только "синий" формат отображения ссылки. Пропишете все гиперссылки - формат ячеек, их содержащих, станет везде одним, "синим").

vlth Наверно я не так выразился, что со мной часто происходит . Мне надо так, видите 1,2,3,4? попробуйте 1 опустить вниз, получилось так, сама гиперссылка перешла как надо но 1 стало черным а 2 стало синим и принял формат гиперссылки а мне надо что б они просто обменивались местами (то что без гиперссылок оставались такими же а те что с гиперссылками переходили как они есть). Дело в том что надо будет всех клиентов фотографировать а это займет не мало времени и пока я добавлю эти гиперссылки пусть чёрный формат так и остается. доработайте пожалуйста.

Sniper1, измените окончание процедуры prcMoveRow:
Код: .Offset(intOf).Delete Shift:=xlUp
End If
End With
End If
End With
With oCell
subHL .Parent.Cells(.Row, 1)
.Select
End With
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

кстати vlth почему когда между 15й и 16й строкой идет обмен строками то в A18 подсчет происходит не верный. сейчас обратил внимание что там в A18 меняется почему то формула при операции между этих строк (и только если 3 опускаешь вниз то формула меняется а если назад поднимаешь то формула встает на свои места как надо). почему?

Maximus777 вас тоже хочу попросить подправить кое что. Видите строку 4 и 5? хочу что б формат так и оставался при ротации строк. Например если отпустить строку 4 вниз то она что б осталась точь в точь как она была на прежнем месте, и так же что б строка 5 переходила наверх в таком же формате как она была в строке 5. И такое правило на все строки. Ой уточню, всё выше сказанное относится только к столбу A (то есть к именам клиентов) так как с другими столбами всё в порядке.

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

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

Цитата:

Sniper1, измените окончание процедуры prcMoveRow:
Код:
.Offset(intOf).Delete Shift:=xlUp
End If
End With
End If
End With
With oCell
subHL .Parent.Cells(.Row, 1)
.Select
End With
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
и добавьте в модуль
Код:
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 fncHasHypLnk(c) Then
.ColorIndex = 5
.Underline = xlUnderlineStyleSingle
Else
.ColorIndex = xlAutomatic
.Underline = xlUnderlineStyleNone
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



Добавлено:
Изменить концовку prcMoveRow нужно так:
вместо
Код:
oCell.Select
поставить
Код:

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

Добавлено:

Цитата:

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

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

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

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

Sniper1, забираем... #

Цитата:

Sniper1, забираем... #

Забрал с руками и с ногами но к сожалению возвращаю назад, на доработку. Поменял всё на последний ваш код, всё что просил вроде работает на ура но что то странное происходит теперь по всей 18й строке при ротации строк, формулы там меняются в не понятно что особенно в G18 там даже формат самопроизвольно меняется. Смотрите

Цитата:

формулы там меняются в не понятно что

Sniper1, ведите себя корректно. Тем более, не стоит расписываться в своём невежестве: формулы НЕ МЕНЯЮТСЯ, меняется ТИП ССЫЛОК на абсолютный (см. справку Excel "Преобразование типа ссылки между относительным, абсолютным и смешанным").
A1 - относит. тип, $A$1 - абсолютный.
Абсолютный тип подразумевает, что куда бы ни переместили ячейку, адреса ссылок в формуле, которую она содержит, останутся неизменными.
В данном случае тип ссылок неважен (согласитесь, важен результат вычислений, а он - правильный).
Если всё, что я сказал, Вас не убедило, поставьте в коде после слов "Address" следующее:
Код: (RowAbsolute:=False, ColumnAbsolute:=False)

Цитата:

Sniper1, ведите себя корректно. Тем более, не стоит расписываться в своём невежестве: формулы НЕ МЕНЯЮТСЯ, меняется ТИП ССЫЛОК на абсолютный (см. справку Excel "Преобразование типа ссылки между относительным, абсолютным и смешанным").

Я сильно извиняюсь за свою не корректность, хотя даже и в мыслях этого не было. Эт наверное вышло и-за моих не знаний К ЭКСЕЛЮ, я ведь в нём только хорошо знаю как открыть и закрыть .


Цитата:

A1 - относит. тип, $A$1 - абсолютный.
Абсолютный тип подразумевает, что куда бы ни переместили ячейку, адреса ссылок в формуле, которую она содержит, останутся неизменными.
В данном случае тип ссылок неважен (согласитесь, важен результат вычислений, а он - правильный).
Если всё, что я сказал, Вас не убедило, поставьте в коде после слов "Address" следующее:

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


Цитата:

Это свойство именно Вашей книги и... проявление неидеальности Excel. C чего детище Microsoft самопроизвольно меняет форматы, понятно не всегда. В данном случае, обойти это просто:

Вот это вот мне и надо что б в G18 формат оставался прежний.


Цитата:

(здесь тип ссылок в формулах уже изменён на относительный)

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