Копирование диапазона с использованием критериев поля со списком

Question

Я пытаюсь скопировать диапазон, который соответствует двум критериям, из двух полей со списком в пользовательской форме.

ComboBox1 содержит критерии 1, филиал.
ComboBox2 содержит критерий 2, квартал.

Столбец A должен соответствовать критериям ветвления, а строка 1 - критериям четверти.

Я не могу заставить мой код работать должным образом. Он только копирует данные из столбца 2 и не проверяет всю строку по критерию Quarters.

Например, если я выберу Жемчужную ветвь и квартал Q1, код должен скопировать "яблоко" и "8".

Вот код:

Private Sub CommandButton1_Click()

Dim LastRow As Long, i As Long, ws2 As Worksheet

With Worksheets("Sheet1")
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

    For i = 2 To LastRow

        If .Cells(i, 1) = ComboBox1 And .Cells(1, 2) = ComboBox2 Then
            With Worksheets("Sheet4")
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = _
                     Worksheets("Sheet1").Cells(i, 2).Value
            End With
        End If

    Next i
End With
Unload Me

End Sub

Answer 1

Основная проблема в вашем коде состоит в том, что, хотя вы правильно просматриваете строки, вы не просматриваете столбцы.

Добавление внутреннего цикла решило бы это. Тем не менее, лучшим решением является использование функции MATCH() для таблицы, чтобы найти соответствующую строку, и вместо этого перебрать столбцы :

Private Sub CommandButton1_Click()

Dim LastColumn As Long
Dim i As Long

With Worksheets("Sheet1")
    LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
    Dim lngMatchingRow As Long
    lngMatchingRow = Excel.WorksheetFunction.Match(ComboBox1.Value, .Range("A:A"), 0)

    For i = 2 To LastColumn

        If .Cells(1, i).Value2 = ComboBox2.Value Then
            With Worksheets("Sheet4")
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = _
                     Worksheets("Sheet1").Cells(lngMatchingRow, i).Value2
            End With
        End If

    Next i
End With
Unload Me

End Sub

Обратите внимание, что я взял на себя смелость изменить некоторые другие части кода, чтобы следовать рекомендациям:

• Переменные должны быть объявлены по одной на строку
• Переменные должны быть объявлены как можно ближе к первому использованию, насколько это возможно
• .Value2 show всегда будет использоваться в предпочтении .Value при извлечении данных из электронной таблицы
• Вместо того, чтобы полагаться на свойства по умолчанию, они должны быть явно указаны, например, ComboBox1.Value вместо ComboBox1

---

Теперь, если бы я писал код с нуля и если кварталы были гарантированно сгруппированы, я бы также обошелся без цикла столбцов.

Вместо этого я бы использовал MATCH() и COUNTIF() чтобы найти пределы столбцов и сразу скопировать данные:

Private Sub CommandButton1_Click()
        Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction

  With Worksheets("Sheet1")
    Dim lngMatchingRow As Long
    lngMatchingRow = ƒ.Match(ComboBox1.Value, .Range("A:A"), 0)
    Dim lngStartCol As Long
    lngStartCol = ƒ.Match(ComboBox2.Value, .Range("1:1"), 0)
    Dim lngColCount As Long
    lngColCount = ƒ.CountIf(.Range("1:1"), "Q1")

    Worksheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(lngColCount) _
    = ƒ.Transpose(.Cells(lngMatchingRow, lngStartCol).Resize(1, lngColCount).Value2)

  End With
  Unload Me

End Sub