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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 2 из 2
  • «
  • 1
  • 2
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Появление "выбиратора" исходя из условий (Макросы/Sub)
Появление "выбиратора" исходя из условий
StoTisteg Дата: Среда, 13.06.2018, 10:20 | Сообщение № 21
Группа: Авторы
Ранг: Ветеран
Сообщений: 877
Репутация: 72 ±
Замечаний: 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(Target.Row, 5).Value = "-------------"
      End If
   End If

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал StoTisteg - Среда, 13.06.2018, 10:21
 
Ответить
Сообщение[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(Target.Row, 5).Value = "-------------"
      End If
   End If

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 13.06.2018 в 10:20
AVI Дата: Среда, 13.06.2018, 11:13 | Сообщение № 22
Группа: Проверенные
Ранг: Обитатель
Сообщений: 257
Репутация: 6 ±
Замечаний: 0% ±

Excel 2016
StoTisteg, Простите, я не знал, как нужно идентифицировать ошибку.
Если я выбираю "Заказ", то ячейка не чистится полностью. Там просто появляется "--------------", а "выбиратор" все еще сидит внутри. Это касается только тех ячеек где несколько поставщиков, например, "Вата (нест. 100 г.)"


Сообщение отредактировал AVI - Среда, 13.06.2018, 11:30
 
Ответить
СообщениеStoTisteg, Простите, я не знал, как нужно идентифицировать ошибку.
Если я выбираю "Заказ", то ячейка не чистится полностью. Там просто появляется "--------------", а "выбиратор" все еще сидит внутри. Это касается только тех ячеек где несколько поставщиков, например, "Вата (нест. 100 г.)"

Автор - AVI
Дата добавления - 13.06.2018 в 11:13
StoTisteg Дата: Среда, 13.06.2018, 11:56 | Сообщение № 23
Группа: Авторы
Ранг: Ветеран
Сообщений: 877
Репутация: 72 ±
Замечаний: 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
            With Cells(Target.Row, 5)
                 .Value = "-------------"
                 .Validation.Delete
           End With
       End If
    End If
End If

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал StoTisteg - Среда, 13.06.2018, 11:59
 
Ответить
СообщениеДа, забыл, прошу пардону.
[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
            With Cells(Target.Row, 5)
                 .Value = "-------------"
                 .Validation.Delete
           End With
       End If
    End If
End If

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 13.06.2018 в 11:56
AVI Дата: Среда, 13.06.2018, 16:52 | Сообщение № 24
Группа: Проверенные
Ранг: Обитатель
Сообщений: 257
Репутация: 6 ±
Замечаний: 0% ±

Excel 2016
StoTisteg, Подскажите, пожалуйста, а что это за единички появились в столбце А?
 
Ответить
СообщениеStoTisteg, Подскажите, пожалуйста, а что это за единички появились в столбце А?

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

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