Question

我有一段代码用于过滤数据表并将可见的单元格复制到新的工作表中。

Sub AddFilter()
'
' AddFilter Macro
'

Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range
Dim copyRange1 As Range, copyRange2 As Range, copyRange3 As Range
Dim filterRange As Range
Dim lastRow As Long

Set src = ThisWorkbook.Sheets("Combined")
Set tgt = ThisWorkbook.Sheets("Dashboard")

lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:Z" & lastRow)
Set copyRange1 = src.Range("A2:A" & lastRow)
Set copyRange2 = src.Range("G2:G" & lastRow)
Set copyRange3 = src.Range("O2:O" & lastRow)

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set rCrit1 = Worksheets("Dashboard").Range("Ref_1")
Set rCrit2 = Worksheets("Dashboard").Range("Ref_2")


Sheets("Dashboard").Range("A1:C3").ClearContents
Sheets("Dashboard").Range("A1:C3").ClearFormats

Selection.AutoFilter
filterRange.AutoFilter Field:=rCrit1, Criteria1:="<>X"
filterRange.AutoFilter Field:=rCrit2, Criteria1:=Worksheets("Dashboard").Range("Ref_3").Value

copyRange1.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A5")
copyRange2.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B5")
copyRange3.SpecialCells(xlCellTypeVisible).Copy tgt.Range("C5")

End Sub

它可以正常工作，但是当我要复制的数据更改时，我必须手动更新它的各个部分。这三个rCrit值来自“仪表板”工作表上的一组4个单元格D2:G2。 D2是数据验证下拉列表。值E2和F2由下拉选择驱动。这些单元格是命名范围Ref_1和Ref_2。 G2是另一个下拉列表，可以是“是”或“否”，此单元格名为范围Ref_3。

要使这段代码自动化，我需要copyRange3动态更新以使用Ref_1作为列数（即，如果Ref_1为15，则copyRange选择列O）。

我还需要将第二个自动过滤条件设为Ref_3的值（是或否）。-根据下面的评论进行修正

Answer 1

问题现在已解决，通过使用如下所示的代码，子程序将根据需要动态更新。通过将偏移量和更改的列的动态值结合使用，副本范围将动态更新。如前所述，更改filterRange代码行允许动态条件

Sub AddFilter()
'
' AddFilter Macro
'

Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range
Dim copyRange1 As Range, copyRange2 As Range, copyRange3 As Range
Dim filterRange As Range
Dim lastRow As Long

Set src = ThisWorkbook.Sheets("Combined")
Set tgt = ThisWorkbook.Sheets("Dashboard")

Set rCrit1 = Worksheets("Dashboard").Range("Ref_1")
Set rCrit2 = Worksheets("Dashboard").Range("Ref_2")

lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:Z" & lastRow)
Set copyRange1 = src.Range("A2:A" & lastRow)
Set copyRange2 = src.Range("C2:C" & lastRow)
Set copyRange3 = src.Range("D2:D" & lastRow)
Set copyRange4 = src.Range("G2:G" & lastRow)
Set copyRange5 = src.Range("A2:A" & lastRow).Offset(0, rCrit1 - 1)

With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Sheets("Dashboard").Range("A5:E" & lastRow).ClearContents
Sheets("Dashboard").Range("A5:E" & lastRow).ClearFormats

Selection.AutoFilter
filterRange.AutoFilter Field:=rCrit1, Criteria1:="<>X"
filterRange.AutoFilter Field:=rCrit2, Criteria1:=Worksheets("Dashboard").Range("Ref_3").Value

copyRange1.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A5")
copyRange2.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B5")
copyRange3.SpecialCells(xlCellTypeVisible).Copy tgt.Range("C5")
copyRange4.SpecialCells(xlCellTypeVisible).Copy tgt.Range("D5")
copyRange5.SpecialCells(xlCellTypeVisible).Copy tgt.Range("E5")

Sheets("Dashboard").Range("A5:E" & lastRow).ClearFormats

End Sub

向VBA代码添加动态引用

1 个答案: