时间戳

首页 > 解决方案 > 应用过滤器 VBA 后如何交换两个单元格范围？

excel - 应用过滤器 VBA 后如何交换两个单元格范围？

问题描述

[![Rows to swap][1]][1]我正在编写一个应用过滤器的代码（标准取自另一个文件，并且工作正常），然后它必须交换两个过滤器的数据行。但是，即使我应用了可见单元格类型函数，它也会在第三行中选择未过滤的数据范围，因此我遇到了错误。

所以基本上在应用过滤器之后，我想在 B76 和 B82 和 G76:AP76 和 G82:AP82 之间交换数据`

Windows("complete Availability 22-3-2021").Activate
ActiveSheet.Range("$A$2:$EL$1561").AutoFilter Field:=1, Criteria1:= _
        po1, Operator:=xlOr, Criteria2:=pi1
Dim r1 As Range
Dim r2 As Range
Set r1 = Range("B2,G2:AP2").Offset(Rowoffset:=1, Columnoffset:=0).SpecialCells(xlCellTypeVisible)
tmp1 = r1
Set r2 = Range("B2,G2:AP2").Offset(Rowoffset:=2, Columnoffset:=0).SpecialCells(xlCellTypeVisible)

tmp2 = r2
r1 = tmp2
r2 = tmp1

End Sub

标签： excelvbaautofilter

解决方案

您没有回答我的澄清问题，但我无法阻止自己认为您需要在过滤范围内交换上述范围。如果是这样，请尝试下一个代码：

Sub testSwapColumnsVC()
 Dim rngF As Range, po1 As String, pi1 As String, r1 As Range, r2 As Range
 Dim arrtemp, firstC As String, lastC As String, cel As Range
 Dim arrHidCol, colN As Long, i As Long, k As Long, sh As Worksheet, boolOptimized As Boolean
 
   boolOptimized = True 'change it in False when debugging!
   
   If boolOptimized Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
   End If
 
  Set sh = ActiveSheet     'use here your sheet by its name
  
  po1 = "AA": pi1 = "BB" 'use here your criteria (I used these only for testing reason)
  
    sh.AutoFilterMode = False 'no need to manually eliminate the filter

    sh.Range("$A$2:$EL$1561").AutoFilter field:=1, Criteria1:= _
                                    po1, Operator:=xlOr, Criteria2:=pi1
                                         
    'Unhide the hidden columns, and memorize them in an array:__
    colN = sh.UsedRange.Columns.count
    ReDim arrHidCol(colN)
    For i = 1 To colN
        If sh.cells(1, i).EntireColumn.Hidden Then
            sh.cells(1, i).EntireColumn.Hidden = False
            arrHidCol(k) = i: k = k + 1
        End If
    Next
    ReDim Preserve arrHidCol(k - 1) 'keep only the array elements having values
    '__________________________________________________
    
    Set rngF = ActiveSheet.Range("$A$2:$EL$1561").SpecialCells(xlCellTypeVisible) 'the filtered Total range
    
    Set r1 = setRangeByRow(rngF, 2)  'create the range of the second filtered/visible cells row
    Set r2 = setRangeByRow(rngF, 3)  'create the range of the third filtered/visible cells row
    
    firstC = r1.cells(1).Address(0, 0)        'r1 Range first cell address
    lastC = Split(r1.Address(0, 0), ":")(1) 'r1 Range last cell address

  arrtemp = Range(firstC & ":" & lastC).value 'keep an unchanged reference of r1 (but continuous range!)
  For Each cel In r1.cells                             'use the r1  cells as column reference!
      cel.value = r2.cells(1, cel.Column - (r1.Column - 1)).value 'swap the cells value placing r2 ones in r1
      'use the temp array to swap in r2 cells:
      r2.cells(1, cel.Column - (r1.Column - 1)).value = arrtemp(1, cel.Column - (r1.Column - 1))
 Next cel
 
 'Hide the previous hidden columns_______
 For i = 0 To UBound(arrHidCol)
    sh.Columns(arrHidCol(i)).Hidden = True
 Next
 '__________________________________
 
 'Remove optimization:
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationManual
 Application.EnableEvents = True
End Sub

Function setRangeByRow(rng As Range, iRow As Long) As Range 'create the range for a specific filtered area row
    Dim i As Long, j As Long, A As Range
    For Each A In rng.Areas
        For j = 1 To A.rows.count
            i = i + 1
            If i = iRow Then
                Set setRangeByRow = Intersect(A.rows(j), rng.Parent.Range("B:B,G:AP"))
                Exit Function
            End If
        Next j
    Next
End Function

编辑：

我也调整了代码以在隐藏列的情况下工作。Excel 无法在不连续范围之间创建准确的交集...

现在，我首先取消隐藏隐藏的列，将它们存储在一个数组中并在最后重新隐藏它们。

除此之外，它还有一些优化设置，以使代码更快。

请在测试后发送一些反馈...

推荐阅读