VBA学习(27)：在筛选数据中复制可见单元格

news2024/11/26 10:23:18

在筛选数据中复制数据时，可以按原结构粘贴所复制的数据。具体如下文：

下图所示为示例数据。

我们对列C进行筛选，如下图所示

复制单元格区域B2:B10，然后粘贴到以单元格E2开始的区域，结果如下图所示。正如所见，我们只能看到部分数据，其它数据被隐藏行所隐藏了。

如果展开隐藏行，实际的粘贴结果如下图所示。

接下来，我们使用下面的代码来进行相同的复制粘贴。代码如下：

'用途:
'复制-粘贴(仅值):
'从筛选的区域到筛选的区域
'从复制的区域到未筛选的区域
'从未筛选的区域到筛选的区域
'对隐藏列没作用
Sub CopyVisibleToVisible2()
 Dim rngA As Range
 Dim rngB As Range, rngBB As Range
 Dim r As Range
 Dim Title As String, txA As String, txB As String
 Dim ra As Long, i As Long
 Dim rc As Long, xCol As Long, a1 As Long, a2 As Long, h As Long
 Dim Flag As Boolean
 
 On Error GoTo skip:
 
 Title = "Copy Visible To Visible"
 Set rngA = Application.Selection
 Set rngA = Application.InputBox("选择要复制的单元格区域, 然后单击确定:", Title, rngA.Address, Type:=8)
 
 '如果选择的是单个单元格,需要粘贴到多个单元格(在筛选的区域)
 If rngA.Cells.CountLarge = 1 Then
   Set rngB = Application.InputBox("选择要粘贴的单元格区域(多个单元格):", Title, Type:=8)
   rngB.SpecialCells(xlCellTypeVisible).Value = rngA.Value
   Exit Sub
 End If
 Set rngB = Application.InputBox("选择要粘贴的单元格区域(仅选择第一个单元格):", Title, Type:=8)
 Set rngB = rngB.Cells(1, 1)
 Application.ScreenUpdating = False
 ra = rngA.Rows.Count
 rc = rngA.Columns.Count
 
 If ra = 1 Then rngB.Resize(, rc).Value = rngA.Value: Exit Sub
 
 '如果所复制的单元格区域被粘贴到相同工作表的相同行
 '因此代码遍历每个可见区域, 这比遍历每个单元格更快.
 If Not Intersect(rngA.Cells(1).EntireRow, rngB) Is Nothing Then
   xCol = rngB.Column
   For Each r In rngA.SpecialCells(xlCellTypeVisible).Areas
     ActiveSheet.Cells(r.Row, xCol).Resize(r.Rows.Count, r.Columns.Count).Value = r.Value
   Next
   '如果所复制的单元格区域没有被复制到相同行, 则检查是否复制单元格区域和粘贴区域有相同的可见单元格结构
 Else
   Set rngB = rngB.Resize(ra, rc)
   a1 = rngA.Columns(1).SpecialCells(xlCellTypeVisible).Areas.Count
   a2 = rngB.Columns(1).SpecialCells(xlCellTypeVisible).Areas.Count
 
   If a1 = a2 Then
     For h = 1 To a1
       '如果两个区域任何相应区域有不同的行数, 意味着可见单元格有不同的结构.
       If rngA.Columns(1).SpecialCells(xlCellTypeVisible).Areas(h).Cells.CountLarge <> rngB.Columns(1).SpecialCells(xlCellTypeVisible).Areas(h).Cells.CountLarge Then
         Flag = True
         Exit For
       End If
     Next
   Else
     Flag = True
   End If
 
   '如果复制区域和粘贴区域有不同的可见单元格结构,
   '那么代码需要遍历两个区域中每一单元格, 这将在大数据中减缓处理速度
   If Flag = True Then
     Set rngA = rngA.Cells(1, 1).Resize(ra, 1)
     For Each r In rngA.SpecialCells(xlCellTypeVisible)
       rngB.Resize(1, rc).Value = r.Resize(1, rc).Value
       Do
         Set rngB = rngB.Offset(1, 0)
       Loop Until rngB.EntireRow.Hidden = False
     Next
     '如果复制区域和粘贴区域有相同的可见单元格结构,
     '那么代码遍历两个可见区域, 这将加快处理速度
   Else
     For i = 1 To rngA.Columns(1).SpecialCells(xlCellTypeVisible).Areas.Count
       rngB.SpecialCells(xlCellTypeVisible).Areas(i).Value = rngA.SpecialCells(xlCellTypeVisible).Areas(i).Value
     Next
   End If
 End If
 
 Application.GoTo rngB
 Application.ScreenUpdating = True
 Application.CutCopyMode = False
 
Exit Sub
skip:
 If Err.Number <> 424 Then
   MsgBox "发现错误: " & Err.Description
 End If
 
 Application.ScreenUpdating = True
 Application.CutCopyMode = False
End Sub

运行代码后，会弹出一个输入框，选择要复制的单元格区域B2:B10，单击“确定”；又会弹出一个输入框，选择要粘贴的单元格区域的第一个单元格，示例中是单元格E2，单击“确定”，结果如下图5所示。正如我们所看到的，与上图3不同，所复制的可见单元格按照原结构完全粘贴。