Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Появление "выбиратора" исходя из условий - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Появление "выбиратора" исходя из условий (Макросы/Sub)
Появление "выбиратора" исходя из условий
AVI Дата: Пятница, 08.06.2018, 11:30 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
Помогите, пожалуйста, сделать такую штуку. Что-то мне подсказывает, что это можно сделать маркосами, в которых я ваще ноль.
В случае, если в ячейке С4 синей таблицы "Склад", то "Вата (нест. 100 г.)" ищется в красной таблице и в D4 отображается поставщик "Вата (нест. 100 г.)" из красной таблицы. Если у "Вата (нест. 100 г.)" в красной таблице несколько поставщиков, то в ячейке D4 синей таблицы появлялся выпадающий выбиратор, который предлагал бы выбрать между всем поставщиками "Вата (нест. 100 г.)" из столбца "поставщики" красной таблицы.
Если получится не маркосами, то бы даже был бы рад еще больше.
К сообщению приложен файл: 9603226.xlsx(11.5 Kb)


Сообщение отредактировал AVI - Пятница, 08.06.2018, 11:33
 
Ответить
СообщениеПомогите, пожалуйста, сделать такую штуку. Что-то мне подсказывает, что это можно сделать маркосами, в которых я ваще ноль.
В случае, если в ячейке С4 синей таблицы "Склад", то "Вата (нест. 100 г.)" ищется в красной таблице и в D4 отображается поставщик "Вата (нест. 100 г.)" из красной таблицы. Если у "Вата (нест. 100 г.)" в красной таблице несколько поставщиков, то в ячейке D4 синей таблицы появлялся выпадающий выбиратор, который предлагал бы выбрать между всем поставщиками "Вата (нест. 100 г.)" из столбца "поставщики" красной таблицы.
Если получится не маркосами, то бы даже был бы рад еще больше.

Автор - AVI
Дата добавления - 08.06.2018 в 11:30
sboy Дата: Пятница, 08.06.2018, 12:05 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2112
Репутация: 605 ±
Замечаний: 0% ±

Excel 2010
[offtop]сколько новых слов :D
маркос, выпадающий выбиратор
 
Ответить
Сообщение[offtop]сколько новых слов :D
маркос, выпадающий выбиратор

Автор - sboy
Дата добавления - 08.06.2018 в 12:05
StoTisteg Дата: Пятница, 08.06.2018, 12:32 | Сообщение № 3
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
А у меня как раз есть подозрения, что это можно формулами, в которых ноль я :)
[vba]
Код
Sub Список()

   Dim i As Long, rw As Long, j As Long
   Dim Arr() As String
   Dim Col As Collection
   
   With ActiveSheet
      With .ListObjects("Таблица2").Sort.SortFields
         .Clear
         .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      End With
      With .Sort
         .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
   End With
   For i = 4 To Cells(Rows.Count, 2).End(xlUp).Row
      Cells(i, 5).Validation.Delete
      Err.Clear
      On Error Resume Next
      rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
      If Err.Number = 0 Then
         If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
            Set Col = New Collection
            Do
               Col.Add Cells(rw, 10).Value
               rw = rw + 1
            Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
            ReDim Arr(1 To Col.Count)
            j = Col.Count
            For j = 1 To Col.Count
               Arr(j) = Col(j)
            Next j
            Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
            Else: Cells(i, 5).Value = Cells(rw, 10).Value
         End If
      End If
   Next i

End Sub
[/vba]
К сообщению приложен файл: 2810487.xlsm(21.3 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеА у меня как раз есть подозрения, что это можно формулами, в которых ноль я :)
[vba]
Код
Sub Список()

   Dim i As Long, rw As Long, j As Long
   Dim Arr() As String
   Dim Col As Collection
   
   With ActiveSheet
      With .ListObjects("Таблица2").Sort.SortFields
         .Clear
         .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      End With
      With .Sort
         .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
   End With
   For i = 4 To Cells(Rows.Count, 2).End(xlUp).Row
      Cells(i, 5).Validation.Delete
      Err.Clear
      On Error Resume Next
      rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
      If Err.Number = 0 Then
         If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
            Set Col = New Collection
            Do
               Col.Add Cells(rw, 10).Value
               rw = rw + 1
            Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
            ReDim Arr(1 To Col.Count)
            j = Col.Count
            For j = 1 To Col.Count
               Arr(j) = Col(j)
            Next j
            Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
            Else: Cells(i, 5).Value = Cells(rw, 10).Value
         End If
      End If
   Next i

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 08.06.2018 в 12:32
Manyasha Дата: Пятница, 08.06.2018, 13:29 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 2193
Репутация: 892 ±
Замечаний: 0% ±

Excel 2010, 2016
Если просто выпадающий список подойдет, то можно так (формула в ctrl+f3):
Код
=ИНДЕКС(Таблица2[Поставщик];ПОИСКПОЗ(Лист1!$B4;Таблица2[Наименование];)):ИНДЕКС(Таблица2[Поставщик];ПОИСКПОЗ(Лист1!$B4;Таблица2[Наименование];)+СЧЁТЕСЛИ(Таблица2[Наименование];Лист1!$B4)-1)


Только таблица поставщиков должна быть отсортирована.
К сообщению приложен файл: 9603226-1.xlsx(11.5 Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеЕсли просто выпадающий список подойдет, то можно так (формула в ctrl+f3):
Код
=ИНДЕКС(Таблица2[Поставщик];ПОИСКПОЗ(Лист1!$B4;Таблица2[Наименование];)):ИНДЕКС(Таблица2[Поставщик];ПОИСКПОЗ(Лист1!$B4;Таблица2[Наименование];)+СЧЁТЕСЛИ(Таблица2[Наименование];Лист1!$B4)-1)


Только таблица поставщиков должна быть отсортирована.

Автор - Manyasha
Дата добавления - 08.06.2018 в 13:29
AVI Дата: Пятница, 08.06.2018, 17:21 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
StoTisteg, Простите, но я не понял как макрос запустить.
Manyasha, В целом, почти то, что нужно. Человека можно будет научить сортировать, спасибо)


Сообщение отредактировал AVI - Пятница, 08.06.2018, 17:23
 
Ответить
СообщениеStoTisteg, Простите, но я не понял как макрос запустить.
Manyasha, В целом, почти то, что нужно. Человека можно будет научить сортировать, спасибо)

Автор - AVI
Дата добавления - 08.06.2018 в 17:21
AVI Дата: Пятница, 08.06.2018, 17:22 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
sboy, С маркосам вышел косяк)
 
Ответить
Сообщениеsboy, С маркосам вышел косяк)

Автор - AVI
Дата добавления - 08.06.2018 в 17:22
_Boroda_ Дата: Пятница, 08.06.2018, 23:43 | Сообщение № 7
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13194
Репутация: 5425 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Еще такой вариант с маленьким макросом и именами (Контрл F3)

* Срабатывает при выделении ячейки в том столбце, где нужен вып. список
К сообщению приложен файл: 9603226_1.xlsm(20.6 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЕще такой вариант с маленьким макросом и именами (Контрл F3)

* Срабатывает при выделении ячейки в том столбце, где нужен вып. список

Автор - _Boroda_
Дата добавления - 08.06.2018 в 23:43
StoTisteg Дата: Суббота, 09.06.2018, 10:08 | Сообщение № 8
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Простите, но я не понял как макрос запустить.

На хоткеи, например, повесить. Иди кнопку прикрутить. Я э не знаю, как Вам удобнее.


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщение
Простите, но я не понял как макрос запустить.

На хоткеи, например, повесить. Иди кнопку прикрутить. Я э не знаю, как Вам удобнее.

Автор - StoTisteg
Дата добавления - 09.06.2018 в 10:08
StoTisteg Дата: Суббота, 09.06.2018, 10:13 | Сообщение № 9
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Повесил Вам его на кнопку и на Ctrl+й.
К сообщению приложен файл: 7887040.xlsm(25.2 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Суббота, 09.06.2018, 10:16
 
Ответить
СообщениеПовесил Вам его на кнопку и на Ctrl+й.

Автор - StoTisteg
Дата добавления - 09.06.2018 в 10:13
StoTisteg Дата: Суббота, 09.06.2018, 10:26 | Сообщение № 10
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
[offtop]"Вода дистиллированная (р-р, 50 мл., №10)"
Раствор воды — это мощно hands В этаноле, что ли? :D


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщение[offtop]"Вода дистиллированная (р-р, 50 мл., №10)"
Раствор воды — это мощно hands В этаноле, что ли? :D

Автор - StoTisteg
Дата добавления - 09.06.2018 в 10:26
AVI Дата: Суббота, 09.06.2018, 14:10 | Сообщение № 11
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
Раствор воды — это мощно

Откуда я знаю что там главная медсестра растворяет в воде)
 
Ответить
Сообщение
Раствор воды — это мощно

Откуда я знаю что там главная медсестра растворяет в воде)

Автор - AVI
Дата добавления - 09.06.2018 в 14:10
AVI Дата: Суббота, 09.06.2018, 14:13 | Сообщение № 12
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
На хоткеи, например, повесить. Иди кнопку прикрутить. Я э не знаю, как Вам удобнее.

Я хотел бы, что маркос срабатывал при выборе "Склад" в столбце "операции". То есть я ввожу дату, выбираю наименование и выбираю "склад" и в это время макрос ищет поставщиков.
 
Ответить
Сообщение
На хоткеи, например, повесить. Иди кнопку прикрутить. Я э не знаю, как Вам удобнее.

Я хотел бы, что маркос срабатывал при выборе "Склад" в столбце "операции". То есть я ввожу дату, выбираю наименование и выбираю "склад" и в это время макрос ищет поставщиков.

Автор - AVI
Дата добавления - 09.06.2018 в 14:13
StoTisteg Дата: Суббота, 09.06.2018, 16:20 | Сообщение № 13
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Тогда где-то так
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)

   Dim i As Long, rw As Long, j As Long
   Dim Arr() As String
   Dim col As Collection
   
   If Target.Cells.Count = 1 Then
      If Target.Column = 3 And Target.Value = "Склад" Then
         With ActiveSheet
            With .ListObjects("Таблица2").Sort.SortFields
               .Clear
               .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
               .Header = xlYes
              .MatchCase = False
              .Orientation = xlTopToBottom
              .SortMethod = xlPinYin
              .Apply
            End With
         End With
         i = Target.Row
         Cells(i, 5).Validation.Delete
         Err.Clear
         On Error Resume Next
         rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
         If Err.Number = 0 Then
            If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
               Set col = New Collection
               Do
                  col.Add Cells(rw, 10).Value
                  rw = rw + 1
               Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
               ReDim Arr(1 To col.Count)
               j = col.Count
               For j = 1 To col.Count
                  Arr(j) = col(j)
               Next j
               Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
               Cells(i, 5).Select
               Else: Cells(i, 5).Value = Cells(rw, 10).Value
            End If
         End If
      End If
   End If

End Sub
[/vba]
К сообщению приложен файл: _-2.xlsm(20.5 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеТогда где-то так
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)

   Dim i As Long, rw As Long, j As Long
   Dim Arr() As String
   Dim col As Collection
   
   If Target.Cells.Count = 1 Then
      If Target.Column = 3 And Target.Value = "Склад" Then
         With ActiveSheet
            With .ListObjects("Таблица2").Sort.SortFields
               .Clear
               .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
               .Header = xlYes
              .MatchCase = False
              .Orientation = xlTopToBottom
              .SortMethod = xlPinYin
              .Apply
            End With
         End With
         i = Target.Row
         Cells(i, 5).Validation.Delete
         Err.Clear
         On Error Resume Next
         rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
         If Err.Number = 0 Then
            If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
               Set col = New Collection
               Do
                  col.Add Cells(rw, 10).Value
                  rw = rw + 1
               Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
               ReDim Arr(1 To col.Count)
               j = col.Count
               For j = 1 To col.Count
                  Arr(j) = col(j)
               Next j
               Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
               Cells(i, 5).Select
               Else: Cells(i, 5).Value = Cells(rw, 10).Value
            End If
         End If
      End If
   End If

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 09.06.2018 в 16:20
AVI Дата: Воскресенье, 10.06.2018, 04:17 | Сообщение № 14
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
StoTisteg, Это здорово!! То что надо, но еще последняя просьба. Можно, что бы, если я ОБРАТНО выбираю "заказ" то содержимое соответствующей ячейки очищалось или, что лучше, заполнялось, например "-------------".
 
Ответить
СообщениеStoTisteg, Это здорово!! То что надо, но еще последняя просьба. Можно, что бы, если я ОБРАТНО выбираю "заказ" то содержимое соответствующей ячейки очищалось или, что лучше, заполнялось, например "-------------".

Автор - AVI
Дата добавления - 10.06.2018 в 04:17
StoTisteg Дата: Вторник, 12.06.2018, 11:58 | Сообщение № 15
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Long, rw As Long, j As Long
Dim Arr() As String
Dim col As Collection

If Target.Cells.Count = 1 Then
    If Target.Column = 3 And Target.Value = "Склад" Then
        With ActiveSheet
            With .ListObjects("Таблица2").Sort.SortFields
            .Clear
            .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
            End With
        End With
        i = Target.Row
        Cells(i, 5).Validation.Delete
        Err.Clear
        On Error Resume Next
        rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
        If Err.Number = 0 Then
            If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
            Set col = New Collection
            Do
                col.Add Cells(rw, 10).Value
                rw = rw + 1
            Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
            ReDim Arr(1 To col.Count)
            j = col.Count
            For j = 1 To col.Count
                Arr(j) = col(j)
            Next j
            Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
            Cells(i, 5).Select
            Else: Cells(i, 5).Value = Cells(rw, 10).Value
            End If
        End If
           Else If Target.Column = 3 And Target.Value = "Заказ" Then Cells(i,5).Value="-------------"
    End If
End If

End Sub
[/vba]
Внимание, код не проверен! Повторюсь, это очень сырой код, который можно и нужно улучшать.


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщение[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Long, rw As Long, j As Long
Dim Arr() As String
Dim col As Collection

If Target.Cells.Count = 1 Then
    If Target.Column = 3 And Target.Value = "Склад" Then
        With ActiveSheet
            With .ListObjects("Таблица2").Sort.SortFields
            .Clear
            .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
            End With
        End With
        i = Target.Row
        Cells(i, 5).Validation.Delete
        Err.Clear
        On Error Resume Next
        rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
        If Err.Number = 0 Then
            If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
            Set col = New Collection
            Do
                col.Add Cells(rw, 10).Value
                rw = rw + 1
            Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
            ReDim Arr(1 To col.Count)
            j = col.Count
            For j = 1 To col.Count
                Arr(j) = col(j)
            Next j
            Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
            Cells(i, 5).Select
            Else: Cells(i, 5).Value = Cells(rw, 10).Value
            End If
        End If
           Else If Target.Column = 3 And Target.Value = "Заказ" Then Cells(i,5).Value="-------------"
    End If
End If

End Sub
[/vba]
Внимание, код не проверен! Повторюсь, это очень сырой код, который можно и нужно улучшать.

Автор - StoTisteg
Дата добавления - 12.06.2018 в 11:58
AVI Дата: Вторник, 12.06.2018, 14:15 | Сообщение № 16
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
StoTisteg, Да)) не сработал)
 
Ответить
СообщениеStoTisteg, Да)) не сработал)

Автор - AVI
Дата добавления - 12.06.2018 в 14:15
StoTisteg Дата: Вторник, 12.06.2018, 14:58 | Сообщение № 17
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
AVI, что говорит-то? А то Эксель под Вайном раскочегаривать - та ещё задачка...


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеAVI, что говорит-то? А то Эксель под Вайном раскочегаривать - та ещё задачка...

Автор - StoTisteg
Дата добавления - 12.06.2018 в 14:58
StoTisteg Дата: Вторник, 12.06.2018, 15:02 | Сообщение № 18
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
Давайте так попробуем:[vba]
Код


Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Long, rw As Long, j As Long
Dim Arr() As String
Dim col As Collection

If Target.Cells.Count = 1 Then
    If Target.Column = 3 And Target.Value = "Склад" Then
        With ActiveSheet
            With .ListObjects("Таблица2").Sort.SortFields
            .Clear
            .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
            End With
        End With
        i = Target.Row
        Cells(i, 5).Validation.Delete
        Err.Clear
        On Error Resume Next
        rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
        If Err.Number = 0 Then
            If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
            Set col = New Collection
            Do
                col.Add Cells(rw, 10).Value
                rw = rw + 1
            Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
            ReDim Arr(1 To col.Count)
            j = col.Count
            For j = 1 To col.Count
                Arr(j) = col(j)
            Next j
            Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
            Cells(i, 5).Select
            Else: Cells(i, 5).Value = Cells(rw, 10).Value
            End If
        End If
        Else
           If Target.Column = 3 And Target.Value = "Заказ" Then
              Cells(i,5).Value="-------------"
           End If
    End If
End If

End Sub
[/vba]


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеДавайте так попробуем:[vba]
Код


Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Long, rw As Long, j As Long
Dim Arr() As String
Dim col As Collection

If Target.Cells.Count = 1 Then
    If Target.Column = 3 And Target.Value = "Склад" Then
        With ActiveSheet
            With .ListObjects("Таблица2").Sort.SortFields
            .Clear
            .Add Key:=Range("Таблица2[[#All],[Наименование]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
            End With
        End With
        i = Target.Row
        Cells(i, 5).Validation.Delete
        Err.Clear
        On Error Resume Next
        rw = Columns(8).Find(what:=Cells(i, 2).Value).Row
        If Err.Number = 0 Then
            If Cells(rw, 8).Value = Cells(rw + 1, 8).Value Then
            Set col = New Collection
            Do
                col.Add Cells(rw, 10).Value
                rw = rw + 1
            Loop While Cells(rw, 8).Value = Cells(rw - 1, 8).Value
            ReDim Arr(1 To col.Count)
            j = col.Count
            For j = 1 To col.Count
                Arr(j) = col(j)
            Next j
            Cells(i, 5).Validation.Add Type:=xlValidateList, Formula1:=Join(Arr, ",")
            Cells(i, 5).Select
            Else: Cells(i, 5).Value = Cells(rw, 10).Value
            End If
        End If
        Else
           If Target.Column = 3 And Target.Value = "Заказ" Then
              Cells(i,5).Value="-------------"
           End If
    End If
End If

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 12.06.2018 в 15:02
AVI Дата: Вторник, 12.06.2018, 17:28 | Сообщение № 19
Группа: Проверенные
Ранг: Обитатель
Сообщений: 434
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
StoTisteg, То же.
run-time error 1004 application-defined or object-defined error
 
Ответить
СообщениеStoTisteg, То же.
run-time error 1004 application-defined or object-defined error

Автор - AVI
Дата добавления - 12.06.2018 в 17:28
StoTisteg Дата: Среда, 13.06.2018, 10:12 | Сообщение № 20
Группа: Авторы
Ранг: Старожил
Сообщений: 1016
Репутация: 86 ±
Замечаний: 0% ±

Excel 2010
AVI, ну что ж из Вас всё клещами-то тянуть надо :) В какой строке?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеAVI, ну что ж из Вас всё клещами-то тянуть надо :) В какой строке?

Автор - StoTisteg
Дата добавления - 13.06.2018 в 10:12
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Появление "выбиратора" исходя из условий (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!