Question

Я пытаюсь создать выпадающее меню в Excel, используя VBA. Когда вы выбираете элемент в раскрывающемся меню, он должен взять именованный диапазон в Рабочей книге и вставить его в диапазон ниже. Я хочу сделать это, чтобы я мог сравнить различные диапазоны.

Я не уверен, как справиться с этим, вот что я пробовал до сих пор:

Function Compare()    
    Dim variable1 As String
    Dim variable2 As String

    Dim dd1 As DropDown
    Dim dd2 As DropDown

    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ActiveWorkbook
    Set ws = Sheets("Compare")

    Set dd1 = ActiveSheet.DropDowns("dropdown1")
    Set dd2 = ActiveSheet.DropDowns("dropdown2")
    Set r1 = ws.Range(dd1.ListFillRange)
    Set r2 = ws.Range(dd2.ListFillRange)

    Set variable1 = r1(dd1.Value)
    Set variable2 = r2(dd2.Value)

    If variable1 = "Example 1" Then        
        wb.ws.Range("h12:j58").Value = Range("ap_ks")        
    End If

End Function

Мне удалось сделать это с помощью оператора IF, но пока только для одного из пунктов. Выполнение этого для всех элементов сделает формулу очень большой, поэтому вместо этого я пытаюсь сделать это в VBA.

{=IFS(D8=Overview!C8;IF(AP_KS=0;"";AP_KS);0=1;)}

SBM · Answer 1 · 28 июня 2019

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

Подмножество столбцов является частично динамическим, основанным на существовании заголовков и некоторых констант;обновляется всякий раз, когда переключаются листы (на мой взгляд, хорошая идея - добавить открытую книгу, а изменение выбора - это перебор).

Private Sub ComboBox1_Change()
Copypasta
End Sub

Private Sub ComboBox2_Change()
Copypasta
End Sub

Private Sub Worksheet_Activate()
' Both sheets.
Update_Combox
End Sub

' I've put the following code in a separate module for accessibility.

Const CFIRSTCOL = 6
Const CLASTCOL = -1
Const CSHEET = "Sheet1"
Const PFIRSTCOL = 1
Const PLASTCOL = -1 ' 3
Const PDEFCOL = 1 ' This is 0 indexed.
Const PSHEET = "Sheet2"

Sub Update_Combox()
' Populates the column selection lists.
Dim indstop As Boolean
Dim i As Integer
Dim ctrlsht
Dim csht
Set csht = Sheets(CSHEET)
Set ctrlsht = Sheets(CSHEET)
ctrlsht.ComboBox1.Clear
indstop = False
i = CFIRSTCOL
While Not indstop
    If i > CLASTCOL And CLASTCOL <> -1 Then
        indstop = True
    ElseIf csht.Cells(1, i) = "" Then
        indstop = True
    Else
        ctrlsht.ComboBox1.AddItem csht.Cells(1, i)
    End If
    i = i + 1
Wend

Set csht = Sheets(PSHEET)
ctrlsht.ComboBox2.Clear
indstop = False
i = PFIRSTCOL
While Not indstop
    If i > PLASTCOL And PLASTCOL <> -1 Then
        indstop = True
    ElseIf csht.Cells(1, i) = "" Then
        indstop = True
    Else
        ctrlsht.ComboBox2.AddItem csht.Cells(1, i)
    End If
    i = i + 1
Wend
ctrlsht.ComboBox2.ListIndex = PDEFCOL
End Sub

Sub Copypasta()
' Copypasta selected column to another sheet.
Dim copycol As Integer
Dim pastacol As Integer
Dim lastrow As Integer
Dim lastrow2 As Integer
Dim csht
Dim psht
Set csht = Sheets(CSHEET)
Set psht = Sheets(PSHEET)
If csht.ComboBox1.ListIndex <> -1 And csht.ComboBox1.ListIndex <> -1 Then
    copycol = CFIRSTCOL + csht.ComboBox1.ListIndex
    pastacol = PFIRSTCOL + csht.ComboBox2.ListIndex
    ' Need to clear the entire pasta range first.
    lastrow2 = psht.Cells(Rows.Count, pastacol).End(xlUp).Row
    if lastrow2 > 1 then
        Range(psht.Cells(2, pastacol), psht.Cells(lastrow2, pastacol)).Clear
    end if

    lastrow = csht.Cells(Rows.Count, copycol).End(xlUp).Row
    Range(psht.Cells(2, pastacol), psht.Cells(lastrow, pastacol)).Value = _
        Range(csht.Cells(2, copycol), csht.Cells(lastrow, copycol)).Value
    'psht.Activate
Else
    ' pass
End If
End Sub

Редактировать: добавлены некоторые заметки и небольшое исправление выше.Включая некоторые снимки ниже для справки.