Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Макрос для выпадающих списков с добавлением новых элементов
 
#1
17.09.2009 12:58:43
Доброго дня Вам!!!    
Есть фаил с выпадающими списками в нём макрос для выпадающих списков с добавлением новых элементов,но внём что то не так,зараза не хочет работать,несколько раз прочитан прием для выпадающего списка http://www.planetaexcel.ru/tip.php?aid=98,и для одного списка макрос из описания работает прекрасно а вот как зделать макрос для нескольких списков  чтоб новые элементы добавлялись каждый в свой список
 
 
 
#2
17.09.2009 13:02:25
Надо два таких макроса каждый для своего диапазона...
 
 
 
#3
17.09.2009 13:07:12
{quote}{login=Микки}{date=17.09.2009 01:02}{thema=}{post}Надо два таких макроса каждый для своего диапазона...{/post}{/quote}  
Пытался два таких макроса вставить, ругался на    
Private Sub Worksheet_Change(ByVal Target As Range)
 
 
 
#4
17.09.2009 13:10:00
Макрос должен иметь свое имя например Добавить(), Добавить1()
 
 
 
#5
17.09.2009 13:16:47
{quote}{login=Микки}{date=17.09.2009 01:10}{thema=}{post}Макрос должен иметь свое имя например Добавить(), Добавить1(){/post}{/quote}  
Делал Private Sub Worksheet_Change1(ByVal Target As Range)  ругался
 
 
 
#6
17.09.2009 13:24:01
Сорь забыл вот мой макрос  
Private Sub Worksheet_Change(ByVal Target As Range)  
Dim lReply As Long  
Dim shSPR As Worksheet, shDannye As Worksheet  
 
Set shSPR = ThisWorkbook.Sheets("Справ")  
Set shDannye = ThisWorkbook.Sheets("Новая")  
'If Target.Column <> 8 Then Exit Sub  
     
 '  shDannye.Select  
     
   If Target.Cells.Count > 1 Then Exit Sub  
   If IsEmpty(Target) Then Exit Sub  
     
   'shSPR.Select  
     
   If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
           
      If WorksheetFunction.CountIf(shSPR.Range("Вид_Док"), Target) = 0 Then  
         lReply = MsgBox("Добавити нове місто відрядження " & _  
                        Target & " до списку?", vbYesNo + vbQuestion)  
         If lReply = vbYes Then  
             shSPR.Range("Вид_док").Cells(shSPR.Range("Вид_док").Rows.Count + 1, 1) = Target  
         End If  
      End If  
    End If  
 
End Sub  
Тут в диапазоне F удет работать со списком Вид_док,  
вставьте друнгой диапазон и другой список должно получится просто не могу сейчас найти.
 
 
 
#7
17.09.2009 13:40:24
{quote}{login=Микки}{date=17.09.2009 01:24}{thema=}{post}Сорь забыл вот мой макрос  
Private Sub Worksheet_Change(ByVal Target As Range)  
Dim lReply As Long  
Dim shSPR As Worksheet, shDannye As Worksheet  
 
Set shSPR = ThisWorkbook.Sheets("Справ")  
Set shDannye = ThisWorkbook.Sheets("Новая")  
'If Target.Column <> 8 Then Exit Sub  
     
 '  shDannye.Select  
     
   If Target.Cells.Count > 1 Then Exit Sub  
   If IsEmpty(Target) Then Exit Sub  
     
   'shSPR.Select  
     
   If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
           
      If WorksheetFunction.CountIf(shSPR.Range("Вид_Док"), Target) = 0 Then  
         lReply = MsgBox("Добавити нове місто відрядження " & _  
                        Target & " до списку?", vbYesNo + vbQuestion)  
         If lReply = vbYes Then  
             shSPR.Range("Вид_док").Cells(shSPR.Range("Вид_док").Rows.Count + 1, 1) = Target  
         End If  
      End If  
    End If  
 
End Sub  
Тут в диапазоне F удет работать со списком Вид_док,  
вставьте друнгой диапазон и другой список должно получится просто не могу сейчас найти.{/post}{/quote}  
 
Видать руки не оттуда растут,всё подставил.......реакция нулевая
 
 
 
#8
17.09.2009 13:44:35
If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
 
If WorksheetFunction.CountIf(shSPR.Range("Вид_Док"), Target) = 0 Then  
lReply = MsgBox("Добавити нове місто відрядження " & _  
Target & " до списку?", vbYesNo + vbQuestion)  
If lReply = vbYes Then  
shSPR.Range("Вид_док").Cells(shSPR.Range("Вид_док").Rows.Count + 1, 1) = Target  
End If  
Вот этот кусок напишите для другого диапазона и другого списка , продублируйте его должно работать, кстати Прайст появился счас он  нам мозги вправит.
 
 
 
#9
17.09.2009 13:45:35
{quote}{login=Микки}{date=17.09.2009 01:44}{thema=}{post}If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
 
If WorksheetFunction.CountIf(shSPR.Range("Вид_Док"), Target) = 0 Then  
lReply = MsgBox("Добавити нове місто відрядження " & _  
Target & " до списку?", vbYesNo + vbQuestion)  
If lReply = vbYes Then  
shSPR.Range("Вид_док").Cells(shSPR.Range("Вид_док").Rows.Count + 1, 1) = Target  
End If  
Вот этот кусок напишите для другого диапазона и другого списка , продублируйте его должно работать, кстати Прайст появился счас он  нам мозги вправит.{/post}{/quote}  
Прайст появился счас он нам мозги вправит,,,,,,,,,,,,,,,,,,,,За чтооооооооооооо??:)
 
 
 
#10
17.09.2009 13:55:10
{quote}{login=Микки}{date=17.09.2009 01:44}{thema=}{post}If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
 
If WorksheetFunction.CountIf(shSPR.Range("Вид_Док"), Target) = 0 Then  
lReply = MsgBox("Добавити нове місто відрядження " & _  
Target & " до списку?", vbYesNo + vbQuestion)  
If lReply = vbYes Then  
shSPR.Range("Вид_док").Cells(shSPR.Range("Вид_док").Rows.Count + 1, 1) = Target  
End If  
Вот этот кусок напишите для другого диапазона и другого списка , продублируйте его должно работать, кстати Прайст появился счас он  нам мозги вправит.{/post}{/quote}  
Private Sub Worksheet_Change(ByVal Target As Range)  
Dim lReply As Long  
Dim shSPR As Worksheet, shDannye As Worksheet  
 
Set shSPR = ThisWorkbook.Sheets("Справ")  
Set shDannye = ThisWorkbook.Sheets("Новая")  
'If Target.Column <> 8 Then Exit Sub  
 
' shDannye.Select  
 
If Target.Cells.Count > 1 Then Exit Sub  
If IsEmpty(Target) Then Exit Sub  
 
'shSPR.Select  
If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
 
If WorksheetFunction.CountIf(shSPR.Range("llll"), Target) = 0 Then  
lReply = MsgBox("Добавити нове місто відрядження  " & _  
Target & " до списку?", vbYesNo + vbQuestion)  
If lReply = vbYes Then  
shSPR.Range("llll").Cells(shSPR.Range("llll").Rows.Count + 1, 1) = Target  
End If  
 
If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
 
If WorksheetFunction.CountIf(shSPR.Range("ppp"), Target) = 0 Then  
lReply = MsgBoxДобавити нове місто відрядження " & _  
Target & " до списку?", vbYesNo + vbQuestion)  
If lReply = vbYes Then  
shSPR.Range("ppp").Cells(shSPR.Range("ppp").Rows.Count + 1, 1) = Target  
End If  
End If  
End If  
 
End Sub  
Зделал так,но видать нетак надо
 
 
 
#11
17.09.2009 13:59:15
Ну во первых у Вас в обоих случаях диапазон F2:F1000, во вторых у меня два разных листа с определенными именами и об этом объявлено в начале макроса-кстати так лучше база на одном справочник на другом , так что либо по схеме моих листов делайте либо убирайте ссылки на них в макросе.
 
 
 
#12
17.09.2009 14:01:39
{quote}{login=The_Prist}{date=17.09.2009 01:51}{thema=}{post}Ни за что. Это Микки так шутит. Но естьвопрос по теме:  
У Вас данные именно так и располагаются как в примере?{/post}{/quote}  
Да именно так, вып.списки начинаются с колонки D а сами списки начинаются с колонки J
 
 
 
#13
17.09.2009 14:02:34
{quote}{login=The_Prist}{date=17.09.2009 01:56}{thema=}{post}Не хотите отвечать на вопрос, держите так.{/post}{/quote}  
Прекрасное конечно решение конкретной задачи... но частный случай... когда на 6 столбцов каждый справочник отстооит от базы .. (но я   так никогда не смогу)
 
 
 
#14
17.09.2009 14:14:50
{quote}{login=The_Prist}{date=17.09.2009 02:00}{thema=}{post}Только добавьте там вначале еще такую строку  
 
If Intersect(Range("D:E"), Target) Is Nothing Then Exit Sub  
или вот доделанный файл.{/post}{/quote}  
O клас!как всегда работает!!!  
для справочки вопрос,етот макрос как я понемаю можно использоать только если списки находятся на одном листе,главное в нём ето Target.Column + 6  
если ерунду спросил,,,,,несерчайте
 
 
 
#15
17.09.2009 14:16:27
{quote}{login=The_Prist}{date=17.09.2009 02:08}{thema=Re: Re: }{post}{quote}{login=Микки}{date=17.09.2009 02:02}{thema=Re: }{post}когда на 6 столбцов каждый справочник отстооит от базы .. (но я   так никогда не смогу){/post}{/quote}Ну можно и на другой лист вынести. Списки надо полагать все равно располагаются закономерно. В любом случае логичнее и практичнее именно так их располагать(последовательно, согласно данным на рабочем листе). Тем более, если лист с данными планируется скрыть. Какая разница в каком там порядке будут располагаться списки? А для макроса проще. Да и короче.{/post}{/quote}  
извеняйте,,,,,торможу с вопросами!!! всё понял.Ограмадное спасибо
 
 
 
#16
17.09.2009 14:57:45
{quote}{login=The_Prist}{date=17.09.2009 02:23}{thema=}{post}Вот со списками на другом листе("DATA").{/post}{/quote}  
Вообще космос,Огромадное спасибо
 
 
 
#17
17.09.2009 15:56:43
{quote}{login=NIKE1972}{date=17.09.2009 02:57}{thema=Re: }{post}{quote}{login=The_Prist}{date=17.09.2009 02:23}{thema=}{post}Вот со списками на другом листе("DATA").{/post}{/quote}  
Вообще космос,Огромадное спасибо{/post}{/quote}  
Я же обещал придет Прайст и всем вправит мозги.
 
 
 
#18
17.09.2009 16:19:06
Хорошо бы еще каждый столбец сортировать для справки.. не могу обратится к последненму заполненному в Дата  диапазону так ошибку дает;  
.Range((.Cells(1, Target.Column - 3),.Cells(lLastRow, Target.Column - 3)).Select  
что не так?
 
 
 
#19
17.09.2009 16:31:41
Вот теперь совсем хорошо.. готовый продукт хоть на 5 хоть на 10 столбцов.
 
 
 
#20
17.09.2009 16:36:22
{quote}{login=The_Prist}{date=17.09.2009 04:25}{thema=}{post}Для тех, кому трудно поправить код своими силами. Добавление с сортировкой.{/post}{/quote}  
А нельзя разве как у меня было в одном макрое выбирать разные диапазоны -для разных именнованных списков?  
If Not Intersect(Target, Range("F2:F10000")) Is Nothing Then  
.....  
If Not Intersect(Target, Range("E2:E10000")) Is Nothing Then  
И т.д.?
 
 
 
#21
17.09.2009 17:04:10
{quote}{login=The_Prist}{date=17.09.2009 04:56}{thema=Re: Re: }{post}{quote}{login=Микки}{date=17.09.2009 04:36}{thema=Re: }{post}А нельзя разве как у меня было в одном макрое выбирать разные диапазоны -для разных именнованных списков?{/post}{/quote}Можно. Но представь как расширится код, если диапазонов и списков более 10? А код-то одинаковый. Разница лишь в столбцах. Можно, конечно, и отдельную процедуру(с передаваемыми параметрами) добавления написать. Но зачем? Это от частного случая зависит.{/post}{/quote}  
Я понял потому и скачал примерчик Спасибо
 
 
 
#22
17.09.2009 17:15:46
В соседней теме еще один пример    
http://www.planetaexcel.ru/docs/forum_upload/post_62581.xls
 
 
 
Страницы: 1
Наверх