» Excel VBA (часть 3)

Цитата:

ехал наконец!
Может кто-то подскажет, сталкивался с такой проблемой:
создаю запрос ms sql (доступ по odbc)  
SELECT ..............
FROM ..............
WHERE FILD_NAME LIKE '%Вася%

vchobo
А кавычки вместо апострофов не помогат? понимаю, что глупо, но все же

vlth


Цитата:

vchobo
А к какой СУБД запрос создаёте?

SQL Server 2005 Express Edition, через ODBC, Импорт внешних данных, SELECT ...


Drazhar

Цитата:

vchobo
А кавычки вместо апострофов не помогат? понимаю, что глупо, но все же

Пробовал всякие..., все как в моем первом посте по ссылке.
Не работает даже 'Вася', "Вася", 'Vasya', в смысле сразу вылетает ошибка

гм. завтра на работе посмотрю. Если не забуду конечно

Sniper1
В модуле ЭтаКнига:
Код: Private Sub Workbook_Open()
With Application.CommandBars("Cell")
With .Controls.Add(Type:=msoControlButton)
.Caption = "Переместить строку вв&ерх"
.OnAction = "prcRowUp"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Переместить строку вн&из"
.OnAction = "prcRowDown"
End With
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application.CommandBars("Cell").Controls
.Item("Переместить строку вверх").Delete
.Item("Переместить строку вниз").Delete
End With
End Sub

Sniper1
Поясню. В панель "ячейка" (вызывается щелчком правой клавиши мыши в области раб. листа) добавляются команды. Назовём их условно "Вверх" и "Вниз". Перемещать строку можно двумя способами.
1. Выбрав соответствующую команду в панели "ячейка" левой кнопкой мыши;
2. Запустив команду после щелчка правой кнопкой мыши горячей клавишей ("Вверх" - "е", "Вниз" - "и").
Второй способ предпочтительнее при многократном перемещении строки ("правая клавиша" - "и", "правая клавиша" - "и" и т.д. — сколько раз это выполним, на столько строк переместим строку, содержащую активную ячейку, вниз)

Цитата:

Sniper1
Поясню. В панель "ячейка" (вызывается щелчком правой клавиши мыши в области раб. листа) добавляются команды. Назовём их условно "Вверх" и "Вниз". Перемещать строку можно двумя способами.
1. Выбрав соответствующую команду в панели "ячейка" левой кнопкой мыши;
2. Запустив команду после щелчка правой кнопкой мыши горячей клавишей ("Вверх" - "е", "Вниз" - "и").
Второй способ предпочтительнее при многократном перемещении строки ("правая клавиша" - "и", "правая клавиша" - "и" и т.д. — сколько раз это выполним, на столько строк переместим строку, содержащую активную ячейку, вниз)

Первый вариант сработал а вот второй не хочет, видать и-за отсутствия русской клавы.

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

Цитата:

Первый вариант сработал а вот второй не хочет, видать и-за отсутствия русской клавы.

Код: With .Controls.Add(Type:=msoControlButton)
.Caption = "Переместить строку вв&ерх"
.OnAction = "prcRowUp"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Переместить строку вн&из"
.OnAction = "prcRowDown"
End With

vlth

Цитата:

Нет, такого я не сделаю.

А почему бы и нет?


Код: Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Integer) As Integer

Public Function CtrlKey() As Boolean
CtrlKey = GetAsyncKeyState(vbKeyControl)
End Function

Public Function ShiftKey() As Boolean
ShiftKey = GetAsyncKeyState(vbKeyShift)
End Function

Public Function AltKey() As Boolean
AltKey = GetAsyncKeyState(vbKeyMenu)
End Function

Цитата:

vlth

Цитата:Нет, такого я не сделаю.


А почему бы и нет?

Maximus777, вот именно потому, что не хотелось искать эти фукции
Спасибо.

Добавлено:
Maximus777
Всё равно пришлось копаться : ты забыл про
Код: Public Function UpKey() As Boolean
UpKey = GetAsyncKeyState(&H26)
End Function
Public Function DownKey() As Boolean
DownKey = GetAsyncKeyState(&H28)
End Function

Цитата:

Больше всего мне не нравится в этой идее, что обозначенное комбинация является одной из "горячих" в Excel.

Да, об этом я конечно не подумал. У меня этот трюк используется в сочетании с кликом по контролам в форме, т.е. Shift+тык в кнопку=действие.


Цитата:

Public Function UpKey() As Boolean

У меня без этого работает. Может потому, что в основном всё через формы делается? Окошек я наплодил в коде, мама не горюй. С градиентыми фонами и контролами с темами ХР. Ну и API много заюзано.

Цитата:

Может потому, что в основном всё через формы делается?

Скорее всего. Может, где-то перехват сделан, да ты подзабыл. Кроме того, в контролах могут быть зашиты свои обработчики.
Вот, кстати, интересный момент на эту тему: TextBox (ms forms 2.0) в VBA и в VB6 по-разному реагирует на клавишу ENTER. В VB - перевод строки-возврат каретки, а в VBA - переход на след. контрол (если TabStop=True) или ничего (если TabStop всех других элементов формы выставлены в False).

Цитата:

TextBox (ms forms 2.0) в VBA и в VB6 по-разному реагирует на клавишу ENTER.

Сдаётся мне они и на кнопку "стрелка вниз" тоже непонятно реагируют. Мне пришлось кое-где заменить TextBox на другой контрол. Плюс получился в том, что на стрелку реакция внятная, темы ХР поддерживает. Но зато правая кнопка не пашет. Вобщем нет в жизни щастья. Обязательно ложка дёгтя присутствует.

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


Цитата:

Sniper1, что Вы подразумеваете под содержимым? - формулы, примечания, форматы (кроме заливки) надо перекидывать?
Подумайте, что ещё, кроме значений, Вам надо перемещать в другую строку.

Как вам сказать то, думаю всё, кроме как заливки и границы ячеек что б не трогало.

Цитата:

как это теперь убрать?

Походу вот это не отработало

Код: Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application.CommandBars("Cell").Controls
.Item("Переместить строку вверх").Delete
.Item("Переместить строку вниз").Delete
End With

Цитата:

Цитата:
как это теперь убрать?

Походу вот это не отработало

Код:

И как теперь отработать?

Цитата:

Походу вот это не отработало

Точно.
Надо было изменить код так:
Код: Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application.CommandBars("Cell").Controls
.Item("Переместить строку Up").Delete
.Item("Переместить строку Down").Delete
End With

Цитата:

Цитата:
Походу вот это не отработало

Точно.
Надо было изменить код так:
Код:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Application.CommandBars("Cell").Controls
.Item("Переместить строку Up").Delete
.Item("Переместить строку Down").Delete
End With

Теперь запускайте эту процедуру, пока не будет сообщения об ошибке

Код:

Вообщем удалил не нужные строки. жду дальнейших решений которые просил чуть выше.

Sniper1
Кнопки сделал. Щас обмен строк сделаю поэлегантнее и выложу.

Цитата:

Sniper1
Кнопки сделал. Щас обмен строк сделаю поэлегантнее и выложу.

Спасибо вам огромное, с нетерпением жду вашего творения.

Module1

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

Sub prcRowUp()
r = ActiveCell.Row
r1 = r - 1
On Error Resume Next
If r > 1 Then
RG = Rows(r)
RG1 = Rows(r1)
Rows(r1) = RG
Rows(r) = RG1
Rows(r1).Select
End If
End Sub

Sub prcRowDown()
r = ActiveCell.Row
r1 = r + 1
On Error Resume Next
RG = Rows(r)
RG1 = Rows(r1)
Rows(r1) = RG
Rows(r) = RG1
Rows(r1).Select
End Sub

Цитата:

Module1

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

Sub prcRowUp()
r = ActiveCell.Row
r1 = r - 1
On Error Resume Next
If r > 1 Then
RG = Rows(r)
RG1 = Rows(r1)
Rows(r1) = RG
Rows(r) = RG1
Rows(r1).Select
End If
End Sub

Sub prcRowDown()
r = ActiveCell.Row
r1 = r + 1
On Error Resume Next
RG = Rows(r)
RG1 = Rows(r1)
Rows(r1) = RG
Rows(r) = RG1
Rows(r1).Select
End Sub

Правда если есть формулы, то они идут по бороде. Как поменять строки с формулами, надо думать дальше.

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

Sniper1

Код: Private Sub Workbook_Open()
With Application
.OnKey "^+{Up}", "prcRowUp"
.OnKey "^+{Down}", "prcRowDown"
End With
End Sub


Sub prcRowUp()
Dim oRow As Range, oTable As Range, oCell As Range
Set oTable = ActiveSheet.Range(Cells(4, 1), Cells(16, 9))
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(1).EntireRow.Row Then
.Cut
.Offset(-1).Insert 'Shift:=xlDown
.Offset(1).Insert Shift:=xlDown
.Copy
.Offset(1).PasteSpecial xlPasteFormats
.Offset(2).Copy
.PasteSpecial xlPasteFormats
.Offset(1).Copy
.Offset(2).PasteSpecial xlPasteFormats
.Offset(1).Delete Shift:=xlUp
End If
End With
End If
End With
oCell.Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub prcRowDown()
Dim oRow As Range, oTable As Range, oCell As Range
Set oTable = ActiveSheet.Range(Cells(4, 1), Cells(16, 9))
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(13).EntireRow.Row Then
.Cut
.Offset(2).Insert 'Shift:=xlDown
.Insert Shift:=xlDown
.Copy
.Offset(-1).PasteSpecial xlPasteFormats
.Offset(-2).Copy
.PasteSpecial xlPasteFormats
.Offset(-1).Copy
.Offset(-2).PasteSpecial xlPasteFormats
.Offset(-1).Delete Shift:=xlUp
End If
End With
End If
End With
oCell.Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Одна голова хорошо, а две лучше. А три, это уже Змей горыныч

Цитата:

формулы у меня тока в столбе "H". Подумайте на досуге как решить и эту задачу.

Вот вам полное решение, учитывая именно столбец "H", а также учитывая тот факт, что в столбце "H" по строкам одинаковые формулы.

Код: 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) 'Аргументы: Строка, Направление
f = Cells(r, 8).FormulaR1C1 '8 - это столбец "H"
r1 = r + 1 * dr
RG = Rows(r)
RG1 = Rows(r1)
Rows(r1) = RG
Rows(r) = RG1
Range(Cells(r, 8), Cells(r1, 8)).Formula = f
Rows(r1).Select
End Sub

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

Sub RowDown()
Call Mov(ActiveCell.Row, 1)
End Sub

Цитата:

Sniper1

Код:
Private Sub Workbook_Open()
With Application
.OnKey "^+{Up}", "prcRowUp"
.OnKey "^+{Down}", "prcRowDown"
End With
End Sub


Sub prcRowUp()
Dim oRow As Range, oTable As Range, oCell As Range
Set oTable = ActiveSheet.Range(Cells(4, 1), Cells(16, 9))
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(1).EntireRow.Row Then
.Cut
.Offset(-1).Insert 'Shift:=xlDown
.Offset(1).Insert Shift:=xlDown
.Copy
.Offset(1).PasteSpecial xlPasteFormats
.Offset(2).Copy
.PasteSpecial xlPasteFormats
.Offset(1).Copy
.Offset(2).PasteSpecial xlPasteFormats
.Offset(1).Delete Shift:=xlUp
End If
End With
End If
End With
oCell.Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub prcRowDown()
Dim oRow As Range, oTable As Range, oCell As Range
Set oTable = ActiveSheet.Range(Cells(4, 1), Cells(16, 9))
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(13).EntireRow.Row Then
.Cut
.Offset(2).Insert 'Shift:=xlDown
.Insert Shift:=xlDown
.Copy
.Offset(-1).PasteSpecial xlPasteFormats
.Offset(-2).Copy
.PasteSpecial xlPasteFormats
.Offset(-1).Copy
.Offset(-2).PasteSpecial xlPasteFormats
.Offset(-1).Delete Shift:=xlUp
End If
End With
End If
End With
oCell.Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub


Добавлено:
Этот код исключительно под Ваши таблицы. Причём в том виде, в котором Вы их представили, включая кол-во строк. В "новую строку" копируется всё, кроме форматов - как Вы и хотели.

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


Цитата:

Одна голова хорошо, а две лучше. А три, это уже Змей горыныч

А тем более три головы как ваши с vlth это вообще атас.


Цитата:

Цитата:
формулы у меня тока в столбе "H". Подумайте на досуге как решить и эту задачу.

Вот вам полное решение, учитывая именно столбец "H", а также учитывая тот факт, что в столбце "H" по строкам одинаковые формулы.

Код:

Идеальный вариант просто не к чему придраться.

Хе, только начал радоваться а тут заметил кое что, что не отрабатывается. Короче в столбе "A" у меня там гиперссылки будут на фотографии клиентов, каждая строка это клиент. так вот надо что б гиперссылки бежали за своими клиентами то есть за строками. Прикладываю файл для наглядности.

Цитата:

Maximus777
Вот вам полное решение, учитывая именно столбец "H", а также учитывая тот факт, что в столбце "H" по строкам одинаковые формулы.

Молодец!!! Здорово работает!

vlth

Цитата:

Добавлено:
Этот код исключительно под Ваши таблицы. Причём в том виде, в котором Вы их представили, включая кол-во строк. В "новую строку" копируется всё, кроме форматов - как Вы и хотели.

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

Хотелось бы узнать можно ли в комментарий к ячейке добавить картинку(точнее ссылку на картинку в интернете)
Знающие люди подскажите есть ли решение моей проблемы!

Цитата:

можно ли в комментарий к ячейке добавить картинку(точнее ссылку на картинку в интернете)

Туда можно добавить любой текст. Ссылка так и будет там выглядеть, как строка текста. Если надо картинкой, то эт вряд ли.


Цитата:

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

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

Maximus777


К моему счастью ты неправ)

Может кому пригодится функция добавляет к ячейке комментарий, в котором график изменения евро за 5 дней. Информация берется с сайты ЦБРФ

Sub com()
dat = Date
datt = Date - 5
Range("O15").AddComment
Range("L15").Comment.Visible = True
sURI = "http://cbr.ru/currency_base/GrafGen.aspx?date_req1=" & datt & "&date_req2=" _
& dat & "&VAL_NM_RQ=R01010"
Range("O15").Comment.Shape.Fill.UserPicture (sURI)
End Sub

Цитата:

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

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


Цитата:

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

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

Цитата:

добавляет к ячейке комментарий, в котором график

И впрямь добавляет. Только там L на O надо поправить. Спасибо за инфу. Будем знать.