» Excel VBA (часть 3)

aidomars
Давай попробую, но мне нужен доступ, у меня нет МТС Россия.

andrewkard1980
с этим проблема, сам понимаешь...

Оптимизируйте пожалуйста

Код: Private Sub CBut5_Click()
Range("L39:U44").Select
Selection.Copy
Range("L5:U10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

Range("L39:U44").Copy Range("L5")

Ребят, дико извиняюсь, в VBA ничего не понимаю, копать все N страниц форума и найти нужное вряд ли смогу.
Нужна обычная кнопка которая бы по нажатии заменяла значение в ячейке с увеличением на 1. Т.е. было например 20, клац кнопку стало 21.
Спасибо и извините за неудобства.

snow1eopard

snow1eopard
поставь элемент управления "счетчик" с панели форм. Там и уменьшать можно будет, и VBA никакого не надо

Dim n_Mes As Integer
Sheets(2).Range("A1").Value = ScrollBar1.Value
n_Mes = Sheets(2).Range("A1").Value
Sheets("Лист2").Select
If n_Mes = 1 Then
Range("A3").Select
ElseIf n_Mes = 2 Then Range("A4").Select: ElseIf n_Mes = 3 Then Range("A5").Select
ElseIf n_Mes = 4 Then Range("A6").Select: ElseIf n_Mes = 5 Then Range("A7").Select
ElseIf n_Mes = 6 Then Range("A8").Select: ElseIf n_Mes = 7 Then Range("A9").Select
ElseIf n_Mes = 8 Then Range("A10").Select: ElseIf n_Mes = 9 Then Range("A11").Select
ElseIf n_Mes = 10 Then Range("A12").Select: ElseIf n_Mes = 11 Then Range("A13").Select
ElseIf n_Mes = 12 Then Range("A14").Select
End If

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

Younko
Можно как то так:

Код: With Sheets(2)
.Select
If .ScrollBar1.Value > 0 Then .Range("A" & .ScrollBar1.Value + 2).Select
End With

Товарищи, подскажите, пожалуйста, как можно сделать в текстбоксе первую букву прописную (без нажатия клавиша Shift), а далее без прописной?
Например, Привет, а не привет.

Anton T
Не могу проверить сейчас, попробуйте StrConv использовать

andrewkard1980
Private Sub TB1_Enter()
TB1.Text = StrConv(TB1.Value, vbProperCase)
End Sub

не вышло
уже всё, разобрался
Private Sub TB1_Change()
TB1.Text = StrConv(TB1.Text , vbProperCase)
End Sub

У меня такая проблема. В книге Excel 2010 на листе есть гиперссылки на сетевой ресурс. Они сделаны через меню Вставка - Гиперссылка. Сетевой путь на который они ссылаются содержит в том числе русские буквы и пробелы. Так вот, периодически начальная часть пути всех этих гиперссылок в книге самопроизвольно заменяется на локальный путь типа "C:\Users\<имя_пользователя>\AppData\Roaming\Microsoft\Excel".

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

Вопрос. Как мне при щелчке по фигуре прочитать текст с нее?
Если предложите другой выход из данной ситуации, тоже буду рад.
Спасибо.

Еще вариант, я могу обрабатывать двойной щелчок по ячейке на листе и в зависимости от содержимого ячейки совершать дальнейшие действия.
Только при двойном щелчке, после выполнения макроса ячейка переходит в режим редактирования, что неудобно.
Можно ли как-то отменить вход в режим редактирования ячейки или в конце выполнения макроса выйти из него (типа послать нажатие ESC), как будто туда и не входили?

Добавлено:
Решил сам свою задачу, по крайней мере по второму варианту.
Чтобы быстро выйти из режима редактирования ячейки эмулирую нажатие клавишы ESC.


Код:
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' здесь что-то делаем ...
keybd_event 27, 0, 0, 0
keybd_event 27, 0, 2, 0
End Sub

Lovec
Может не рисовать фигуры, а использовать конструкцию =ГИПЕРССЫЛКА($А$1),
вряд ли теперь что то будет менятся. Еще вариант поместить гиперссылку в квадратные скопки или одинарные кавычки. Не пробовал...

Lovec
Если хочешь сам обрабатывать переход по гиперссылке, то проще поставить в ячейке ссылку на саму себя (чтобы отключить автоматический переход), в тексте ячейки написать правильную ссылку, а переход делать через


Код: Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
SomehowGoTo Target.TextToDisplay
End Sub

Добрый день
Напишите пожалуйста код для следующей операции:
На листе "Деталировка" находится форма "Image1" мне необходимо что бы в зависимости от значения (от 1 до 12) указанного в ячейке "А1", в форме "Image1"отображалось соответствующее изображение.

TXPЕсли речь идет про элемент управления "Рисунок", то где-то так:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A1")) Is Nothing Then
Image1.Picture = LoadPicture("Path to image" & Me.Range("A1").Value & ".ext")
End If
End Sub

panda3
Спасибо, все как надо работает.

Проверьте и поправьте пожалуйста код.

На основании данных приведенных в ячейках S1, T1, U1, V1 формируется деталировка изделия и в зависимости от значения выше приведенных ячеек, на листе отображаются или скрываются необходимые изображения.



Код: Private Sub Worksheet_Activate()
Range("S1:V1").Value = Sheets("Расчет").Range("M21:P21").Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Me.Range("S1")) Is Nothing Then
Image1.Picture = LoadPicture("F:\Эскиз\" & Me.Range("S1").Value & ".jpg")
End If
If Me.Range("T1").Value > 0 Then
Image2.Picture = LoadPicture("F:\Эскиз\" & Me.Range("T1").Value & ".jpg")
Rows("21:36").EntireRow.Hidden = False
Image2.Height = 142.5
Image2.Width = 457.5
Image2.Top = 316.5
Image2.Left = 0.75

Else
Image2.Picture = LoadPicture("")
Rows("21:36").EntireRow.Hidden = True
End If

If Range("U1").Value = 0 Then
Image3.Picture = LoadPicture("F:\Эскиз\13.jpg")
Else
Image3.Picture = LoadPicture("F:\Эскиз\11.jpg")
End If

If Range("V1").Value = 0 Then
If Range("U1").Value = 0 Then
Image4.Picture = LoadPicture("")
Range("J40:K43").Borders.LineStyle = xlNone
Else
Image4.Picture = LoadPicture("F:\Эскиз\13.jpg")
Range("J40:K43").Borders.LineStyle = xlContinuous
End If

Else
Image4.Picture = LoadPicture("F:\Эскиз\12.jpg")
Range("J40:K43").Borders.LineStyle = xlContinuous
End If

If Range("U1").Value = 0 Then
Image5.Picture = LoadPicture("")
Range("O40:P42").Borders.LineStyle = xlNone
Else
If Range("V1").Value = 0 Then
Image5.Picture = LoadPicture("")
Range("O40:P42").Borders.LineStyle = xlNone
Else
Image5.Picture = LoadPicture("F:\Эскиз\13.jpg")
Range("O40:P42").Borders.LineStyle = xlContinuous
End If

End If
End Sub

Приветствую.

Подскажите, есть макрос для OpenOffice. В Excel - не работает, Ругается на синтаксические ошибки, в строке: ParseMap (Head, Col, NumRows).


Код:
Sub Categorize()
Dim Cursor As Object, Map As Object, Range As Object
Dim NumColumns As Long, Col As Long, NumRows As Long
Dim Head As String

Map = ThisComponent.Sheets.getByName("Карта")

Cursor = Map.createCursor
Cursor.gotoEndOfUsedArea (True)
NumColumns = Cursor.Columns.Count

For Col = 0 To NumColumns - 1 Step 2
Head = Map.getCellByPosition(Col, 0).String
If Head <> "" Then
NumRows = LastRowWithData(Col) + 1
ParseMap (Head, Col, NumRows)
End If
Next Col

MsgBox "Обработка ядра завершена.)"
End Sub

Sub ParseMap(ByVal Head As String, ByVal Col As Long, ByVal NumMarks As Long)
Dim Names(1 To NumMarks) As String, Keys(1 To NumMarks) As String
Dim Core As Object, Map As Object, Cell As Object, Source As Object, Cursor As Object
Dim I, J, NumRows, CellIndex

CellIndex = GetCellByName(Head)
Core = ThisComponent.Sheets.getByName("Ядро")
Map = ThisComponent.Sheets.getByName("Карта")

For I = 1 To NumMarks
Keys(I) = Map.getCellByPosition(Col, I - 1).String
Names(I) = Map.getCellByPosition(Col + 1, I - 1).String
Next I

Cursor = Core.createCursor
Cursor.gotoEndOfUsedArea (True)
NumRows = Cursor.Rows.Count

For I = 1 To NumRows
Source = Core.getCellByPosition(0, I)
Cell = Core.getCellByPosition(CellIndex, I)

For J = 1 To NumMarks
If InStr(LCase(Source.String), LCase(Keys(J))) > 0 Then
Cell.String = Names(J)
End If
Next J
Next I
End Sub

Function GetCellByName(Head As String)
Dim Core As Object, Cursor As Object
Dim J

Core = ThisComponent.Sheets.getByName("Ядро")

Cursor = Core.createCursor
Cursor.gotoEndOfUsedArea (True)
NumColumns = Cursor.Columns.Count

For J = 1 To NumColumns
If Core.getCellByPosition(J - 1, 0).String = Head Then
GetCellByName = J - 1
Exit Function
End If
Next

Core.Columns.insertByIndex(1, 1)
Core.getCellByPosition(1, 0).String = Head
GetCellByName = 1
End Function

Function LastRowWithData(ColumnIndex As Long) As Long
Dim Cursor As Object, Range As Object, Map As Object
Dim LastRowOfUsedArea As Long, R As Long
Dim RangeData

Map = ThisComponent.Sheets.getByName("Карта")
Cursor = Map.createCursor
Cursor.gotoEndOfUsedArea (False)
LastRowOfUsedArea = Cursor.RangeAddress.EndRow
Range = Map.getCellRangeByPosition(ColumnIndex, 0, ColumnIndex, LastRowOfUsedArea)
Cursor = Map.createCursorByRange(Range)
RangeData = Cursor.getDataArray

For R = UBound(RangeData) To LBound(RangeData) Step -1
If RangeData(R)(0) <> "" Then
LastRowWithData = R
Exit Function
End If
Next
End Function

Помогите, пожалуйста с решением задачи:
Есть таблица, как первая на рисунке, нужно для активной ячейки (выбрали,к примеру, строка1) пройтись по диапазонам E:H , I:L, M:P
и если в диапазоне E:H есть хоть одна заполненная ячейка, то вставляем ее значение в соответствующий столбец второй таблицы, если нет - ничего не делаем. и так по всем диапазонам надо пройти.
не могу додумать, как сделать, чтобы проверялась только активная строка.

картинка: http://7image.ru/v.php?id=360966

Цитата:

как сделать, чтобы проверялась только активная строка

Selection.row или Activecell.row

qwertyuiopa
А в OpenOffice он работает? ParseMap (Head, Col, NumRows), я так понимаю, это функция, которой Вы передаете параметры Head, Col, NumRows и она должна что то Вам вернуть, по идее, должно быть так:

s = ParseMap (Head, Col, NumRows)

в переменной s будет результат выполнения функции ParseMap

поправьте если ошибаюсь

Добавлено:
TXP
А где не работает, или где не правильно работает?

Здравсствуте, люди добрые, помогите найти ошибку?
каждый раз при выборе из комбобокса, в него добавляются элементы заново, и получается список (1,2,3,1,2,3,1,2,3...).Как сделать чтобы элементы в списке были по одному разу все?
если очищаю в начале, то потом почему то вообще не работает что прописано..

Код: Private Sub ComboBox1_Change()
'If Not Me.ComboBox1.ListIndex = -1 Then
' Me.Cells(98, 9) = Me.ComboBox1.Value
' End If

' ComboBox1.Clear

Dim i&

Const iRow = 65536: iClm = "A"
sn = &#203;&#232;&#241;&#242;2.Name
iRws = Sheets(sn).Range(iClm & iRow).End(xlUp).Row
'ComboBox1.ListFillRange = sn & "!" & iClm & "1:" & iClm & iRws

'ComboBox1.Clear

For i = 1 To iRws
If [B100] Like "*" & Sheets(sn).Cells(i, 1) & "*" Then
ComboBox1.AddItem Sheets(sn).Cells(i, 1)
End If

Next i

For i = 1 To iRws
If Sheets(sn).Cells(i, 1) = Me.ComboBox1.Text Then
Cells(98, 9) = Sheets(sn).Cells(i, 2)
End If
Next i
End Sub

umka777_89
Пробуйте как то так:

Код: Private Sub UserForm_Initialize()
ComboBox1.AddItem Worksheets(1).Cells(1, 1)
End Sub
Private Sub ComboBox1_Change()
Dim i&, iRws&
Set sn = Worksheets(1)
iRws = sn.Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To iRws
If sn.[B100] Like "*" & sn.Cells(i, 1) & "*" Then
ComboBox1.AddItem sn.Cells(i, 1)
End If
Next i

For i = ComboBox1.ListCount To 2 Step -1
If ComboBox1.List(i - 1) = ComboBox1.List(i - 2) Then
ComboBox1.RemoveItem (i - 1)
End If
Next i
Set sn = Nothing
End Sub

После игр с запретом копи-паст пропала в меню пр. кн. мыши функция копировать:
http://www.imageup.ru/img234/1358911/bezymyannyjj.jpg.html
можно как то, без переустановки, пофиксить?
Спасибо!

andrewkard1980
Прогоните такой макрос, может поможет

Код:
Public Sub ResetPopup()
Dim p As CommandBar
For Each p In Application.CommandBars
If p.BuiltIn And (p.Type = msoBarTypePopup) Then p.Reset
Next p
End Sub

AndVGri
Благодарствую, очень даже помогло, спасибо!

Здравствуйте. Надо искать текст в текстовом файле. Читаю при помощи Line input. Вопрос: можно ли каким-либо образом указывать, строчку с каким номером надо прочитать? Seek к сожалению указывает смещение в байтах, а мне надо попасть на начало строки с заданным порядковым номером в файле. Иногда надо идти не вперёд по файлу, а назад. Код нужен без .NET и скриптов.

Заранее спасибо.