Excel-VBA黏贴数据时跳过隐藏区域

应用场景

将excel黏贴时仅仅黏贴在显示的单元格中(当目标区域中有隐藏行、列、或者目标区域处于筛选状态,excel黏贴数据时不会跳过隐藏区域)

知识要点

1：SpecialCells(xlCellTypeVisible)  定位可见区域，

2：如果被复制区域有隐藏区域，那么创建一个辅助工作表，将被复制区域的可见区域黏贴到辅助工作表

3：黏贴后的区域不在存在隐藏区域，然后将选区的单元格逐个复制到目标区域，在复制时检查它的状态是否为显示

Sub 黏贴数据时跳过隐藏区()

        Dim Rng As Range, Rngg As Range, Cell As Range, i As Long, Rang As Range, Sht As Worksheet, j As Integer, Col_count As Integer

        On Error Resume Next

        If TypeName(Selection) = 'Range' Then  '仅仅对选择对象是单元格者进行操作

            Set Sht = ActiveSheet   '将当前工作表赋值给变量sht

            '确定黏贴的目标区域

            Set Cell = Application.InputBox('请选择目标区域存放区域，一个单元格即可', '目标区域', , , , , , 8)

            If Err <> 0 Then Exit Sub '如果有错误则退出

            Application.ScreenUpdating = False  '关闭屏幕刷新

            With Selection.SpecialCells(xlCellTypeVisible) '定位选区的可见区域

                If .Address <> Selection.Address Then

                '如果可见区域地址与选区的地址不一致

                    Selection.SpecialCells(xlCellTypeVisible).Copy  '复制选区的可见区域

                    Sheets.Add after:=Sheets(Sheets.Count) '添加一个新表

                    ActiveSheet.Paste '黏贴数据

                    Set Rngg = Selection '将新表中的选区赋予变量

                Else

                    Set Rngg = Selection

                End If

            End With

            Sht.Select '返回原工作表

            '确定目标区域列数

            For i = 1 To 5000 '循环

                '如果目标存放区域的第一个单元格向右偏移 i-1 的单元格的列宽大于（也就是说显示状态）

                If Cell.Offset(0, i - 1).ColumnWidth > 0 Then

                    Col_count = Col_count 1 '那么累加计数器，该计数器代表显示区域的列数

                    '如果计数器等于rngg区域的列数时，终止循环

                    If Col_count = Rngg.Columns.Count Then GoTo begin

                End If

            Next i

            '开始复制选区中可见单元格到目标区域中的可见单元格中

begin:

            Set Cell = Cell.Resize(Rngg.Rows.Count, i)

            '根据rngg的列数和变量i重新指定cell代表的区域

            For Each Rng In Rngg '遍历rngg区域(外层循环)

                For i = 1 To 5000

                    '如果cell区域的j 1 个单元格为显示状态，那么终止里层循环

                    If Cell(j i).RowHeight > 0 And Cell(j i).ColumnWidth > 0 Then GoTo Star

                Next

Star:

                    j = j 1 '累加变量

                    Rng.Copy Cell(j) '逐个复制单元格

            Next Rng

            If Selection.SpecialCells(xlCellTypeVisible).Address <> Selection.Address Then

                Application.DisplayAlerts = False

                Sheets(Sheets.Count).Delete

                Application.DisplayAlerts = True

            End If

            Application.ScreenUpdating = True

        End If

End Sub

--------------------------------------