Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 15.04.2012, 22:22   #1
MaxxVer
Форумчанин
 
Регистрация: 17.03.2009
Сообщений: 226
По умолчанию Доработка VBA кода

Добрый день, уважаемые форумчане! Прошу Вашей помощи в корректировке VBA кода. Во вложении формат для заполнения напичканный макросами (я в них абсолютный ноль), в котором запрограммирована очень неудобная для пользователя функция – при двойном клике мыши на синем названии статьи, добавляется новая строка - неудобно это тем, что добавляется только одна строка, а обычно их нужно довольно много. Прошу Вас скорректировать код так, чтобы при двойном клике открывалось маленькое окошко, в котором пользователь мог указать необходимое количество строк и при дальнейшем нажатии «ОК» добавлялось соответствующее количество строк (строки должны добавляться с тем же функционалом как в оригинале, т.е. приписываться автоматом код строки и №№, копироваться формулы).
Чтобы добраться до необходимого документа нужно: выбрать формат (например 7.1), выбрать период и компанию (любую), высветить свод.
Вложения
Тип файла: rar invest_1.26.rar (235.1 Кб, 23 просмотров)
MaxxVer вне форума Ответить с цитированием
Старый 19.04.2012, 13:48   #2
MaxxVer
Форумчанин
 
Регистрация: 17.03.2009
Сообщений: 226
По умолчанию

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

Private Sub Worksheet_Activate()

'If ActiveWorkbook.Name = "invest_1.1.xls" And Workbooks("invest_1.1.xls").Sheets( "l0").Range("H4") = 0 And Workbooks("invest_1.1.xls").Sheets( "l0").Range("H3") = 0 Then
' Workbooks("invest_1.1.xls").Sheets( "l0").Range("H4") = 1
' UserForm12.Show
'End If

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Cancel = True
If Cells(Target.Row, 5).Font.ColorIndex = 5 Then
If IsEmpty(Cells(Target.Row, 7)) Then
MsgBox "Ââåäèòå íàèìåíîâàíèå ïðîåêòà"
Exit Sub
End If
ActiveSheet.Unprotect
If Cells(Target.Row, 6) < 600 Then
Rows(Format(Target.Row + 35) + ":" + Format(Target.Row + 69)).Insert Shift:=xlDown
Range("E" + Format(Target.Row) + ":E" + Format(Target.Row + 34)).Copy
Range("E" + Format(Target.Row + 35)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("E" + Format(Target.Row) + ":O" + Format(Target.Row + 34)).Copy
Range("E" + Format(Target.Row + 35)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(Target.Row + 35, 5) = "ÏÐÎÅÊÒ/ÐÀÇÄÅË ¹ " + Format(Val(Right(Cells(Target.Row, 5), 2)) + 1, "00")
Cells(Target.Row + 35, 6) = Val(Cells(Target.Row, 6)) + 10
Cells(Target.Row + 36, 6) = Val(Format(Cells(Target.Row + 35, 6)) + "00001")
Cells(Target.Row + 37, 6) = Val(Format(Cells(Target.Row + 35, 6)) + "00002")
Range("F" + Format(Target.Row + 36) + ":F" + Format(Target.Row + 37)).AutoFill Destination:=Range("F" + Format(Target.Row + 36) + ":F" + Format(Target.Row + 69))
Range("E" + Format(Target.Row)).Font.ColorIndex = 1
Range("G" + Format(Target.Row + 35)).Select
Else
Rows(Format(Target.Row + 23) + ":" + Format(Target.Row + 45)).Insert Shift:=xlDown
Range("E" + Format(Target.Row) + ":E" + Format(Target.Row + 22)).Copy
Range("E" + Format(Target.Row + 23)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("E" + Format(Target.Row) + ":O" + Format(Target.Row + 22)).Copy
Range("E" + Format(Target.Row + 23)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells(Target.Row + 23, 5) = "ÏÐÎÅÊÒ/ÐÀÇÄÅË ¹ " + Format(Val(Right(Cells(Target.Row, 5), 2)) + 1, "00")
Cells(Target.Row + 23, 6) = Val(Cells(Target.Row, 6)) + 10
Cells(Target.Row + 24, 6) = Val(Format(Cells(Target.Row + 23, 6)) + "00001")
Cells(Target.Row + 25, 6) = Val(Format(Cells(Target.Row + 23, 6)) + "00002")
Range("F" + Format(Target.Row + 24) + ":F" + Format(Target.Row + 25)).AutoFill Destination:=Range("F" + Format(Target.Row + 24) + ":F" + Format(Target.Row + 45))
Range("E" + Format(Target.Row)).Font.ColorIndex = 1
Range("G" + Format(Target.Row + 23)).Select
End If
ActiveSheet.Protect
End If

End Sub

'Private Sub Worksheet_Change(ByVal Target As Range)
'Dim c1 As Variant
'Dim c2 As Variant
'Dim i As Integer

'With ActiveSheet.Range("f:f")
' Set c1 = .Find("77777", LookIn:=xlValues, LookAt:=xlWhole)
'End With
'i = 6
'Do While Cells(11, i).Interior.Color <> 12632256
' i = i + 1
'Loop

'With Range(Cells(11, 7), Cells(c1.Row, i))
' Set c2 = .Find(":", LookIn:=xlValues, LookAt:=xlPart)
' If Not c2 Is Nothing Then
' MsgBox "Çàïðåùåíî ââîäèòü â òåêñòîâîì ïîëå ñëóæåáíûé ñèìâîë ':' (ñì.Èíñòðóêöèþ)"
' Cells(c2.Row, c2.Column).Select
' End If
'End With

'End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If (Target.Column = 8 Or Target.Column = 9 Or Target.Column = 10 Or Target.Column = 11) And Cells(Target.Row, Target.Column).Locked = False And Cells(Target.Row, 6) <> 55555 And Cells(Target.Row, 6) <> 77777 Then
'UserForm7.Show
End If
If ActiveWorkbook.Name <> "lst_invest.xls" And Target.Column = 7 And Cells(Target.Row, Target.Column).Locked = False And Cells(Target.Row, 6) <> 55555 And Cells(Target.Row, 6) <> 77777 Then
'namefile = "c:/out/etc/invest_pr_" + Sheets("l0").Range("B3").Value + ".txt"
namefile = Sheets("l0").Range("C10").Value + "/etc/invest_pr_" + Sheets("l0").Range("B3").Value + ".txt"
If Dir(namefile) = "" Then
'MsgBox "Íå íàéäåí ñïðàâî÷íèê ïðîåêòîâ"
Exit Sub
End If
UserForm13.Show
End If

End Sub
MaxxVer вне форума Ответить с цитированием
Старый 19.04.2012, 13:57   #3
alex77755
Форумчанин
 
Аватар для alex77755
 
Регистрация: 14.02.2009
Сообщений: 753
По умолчанию

Private Sub Worksheet_BeforeDoubleClick
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru
alex77755 вне форума Ответить с цитированием
Старый 19.04.2012, 14:16   #4
alex77755
Форумчанин
 
Аватар для alex77755
 
Регистрация: 14.02.2009
Сообщений: 753
По умолчанию

Цитата:
добавляется новая строка - неудобно это тем, что добавляется только одна строка, а обычно их нужно довольно много
вообще-то добавляется 35 строк
Код:
Rows(Format(Target.Row + 35) + ":" + Format(Target.Row + 69)).Insert Shift:=xlDown
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru
alex77755 вне форума Ответить с цитированием
Старый 19.04.2012, 14:36   #5
alex77755
Форумчанин
 
Аватар для alex77755
 
Регистрация: 14.02.2009
Сообщений: 753
По умолчанию

И ещё в зависимости от сдержания 6 ячейки выбоанной строки
Код:
If Cells(Target.Row, 6) < 600 Then
Вставляетя либо 35 либо 23 строки
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru
alex77755 вне форума Ответить с цитированием
Старый 19.04.2012, 14:42   #6
alex77755
Форумчанин
 
Аватар для alex77755
 
Регистрация: 14.02.2009
Сообщений: 753
По умолчанию

Добалять несколько блоков можно так(но только добавление, а там ещё есть копирование, вставка, назначение цвета и значений, автозаполнение. для того нужно разбираться, организовывать циклы)
Но это только для первого условия
Код:
Dim Ск As Byte
Ск = InputBox("сколько блоков вставлять", "", 1) - 1
Rows(Format(Target.Row + 35) + ":" + Format(Target.Row + 69 + Ск * 35)).Insert Shift:=xlDown
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru
alex77755 вне форума Ответить с цитированием
Старый 19.04.2012, 15:38   #7
MaxxVer
Форумчанин
 
Регистрация: 17.03.2009
Сообщений: 226
По умолчанию

Спасибо! Попробую поразбираться.
MaxxVer вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
доработка кода на римскую систему счисления ПаЗитиФкА Помощь студентам 0 12.12.2011 20:43
Доработка кода авторизации Fastah БД в Delphi 1 22.03.2011 12:25
Доработка кода авторизации Fastah Помощь студентам 7 22.03.2011 11:45
С++ нужна корректировка\доработка кода. Akmall Помощь студентам 1 19.12.2010 16:34
С++ нужна корректировка\доработка кода. Akmall Помощь студентам 3 10.12.2010 22:51