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

Question

У меня есть:

1) один рабочий лист с именем «Данные» для базы данных моих продуктов;

2) один рабочий лист с именем «Предложение ENG» для котировок продуктов на основе выбранных продуктов избаза данных;

3) один лист с именем «Менеджер» с выпадающими списками для выбора критериев.

Затем у меня есть два фрагмента кода, которые работают независимо друг от друга.

Один с именем Sub Quote предназначен для вставки копий части строк из моей базы данных на лист предложений, когда критерий удовлетворен,

, а другой с именем Sub Worksheet_Change (credits: TrumpExcel) предназначен для включения множественного выбора в раскрывающемся списке.list.

Я совершенно не представляю, как изменить код моего модуля Sub Quote, чтобы сделать возможной операцию копирования-вставки, если раскрывающиеся списки включают несколько критериев.Любое руководство приветствуется:)

Sub Quote()

Dim Source As Worksheet
Dim Target As Worksheet
Dim Company As String
Dim InfoA As String
Dim Finalrow As Integer
Dim I As Integer

Set Source = Worksheets("Data")
Set Target = Worksheets("Quotation ENG")
Company = Worksheets("Manager").Range("E5").Value 'Where one dropdown list is located.
InfoA = Worksheets("Manager").Range("E7").Value 'Where one dropdown list is located.

Source.Select
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row

For I = 2 To Finalrow
    If Cells(I, 1) = Company And Cells(I, 2) = InfoA Then
    Source.Range(Cells(I, 16), Cells(I, 23)).Copy Target.Range("A200").End(xlUp).Offset(1, 0).Resize(1, 8)
    End If

Next I

Target.Select
Range("A1").Select

End Sub

=============================================================

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Oldvalue As String
Dim Newvalue As String

Application.EnableEvents = True
On Error GoTo Exitsub

If Target.Address = "$E$5" Then
  If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
  Else: If Target.Value = "" Then GoTo Exitsub Else
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
      If Oldvalue = "" Then
        Target.Value = Newvalue
      Else
        If InStr(1, Oldvalue, Newvalue) = 0 Then
            Target.Value = Oldvalue & ", " & Newvalue
      Else:
        Target.Value = Oldvalue
      End If
    End If
  End If
End If

Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True

End Sub

Answer 1

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

В качестве рекомендации попробуйте использовать структурированные таблицы Excel для хранения ваших данных.В будущем с ними будет легче работать.

Замените свою текущую сабвуферную цитату на эту:

Sub Quote()

    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Company() As String ' Converted the company variable to an array
    Dim InfoA As String
    Dim Finalrow As Integer
    Dim counter As Integer
    Dim I As Integer

    Set Source = Worksheets("Data")
    Set Target = Worksheets("Quotation ENG")
    Company = Split(Worksheets("Manager").Range("E5").Value, ",") 'Where one dropdown list is located.
    InfoA = Worksheets("Manager").Range("E7").Value 'Where one dropdown list is located.

    ' Added the source sheet and removed the select as it slows down your code
    Finalrow = Source.Cells(Rows.Count, 1).End(xlUp).Row

    ' Loop through each company contained in the array
    For counter = 0 To UBound(Company)
        ' Loop through each data row
        For I = 2 To Finalrow
            ' Added Company(counter) so you can access each array element and wrapped it with trim to delete extra spaces
            If Source.Cells(I, 1) = Trim(Company(counter)) And Source.Cells(I, 2) = InfoA Then
                Source.Range(Source.Cells(I, 16), Source.Cells(I, 23)).Copy Target.Range("A200").End(xlUp).Offset(1, 0).Resize(1, 8)
            End If
        Next I
    Next counter


    ' Activate worksheet
    Target.Activate
    ' Refer to the object full path
    Target.Range("A1").Select

End Sub

Дайте мне знать, если она работает.