【excel实战】-- 批量提取批注&多重区域复制粘贴

系列文章目录

---

前言

一、多区域复制粘贴

Sub 多区域复制粘贴()

On Error Resume Next

Dim SRange() As Range, UPRange As Range, TRange As Range

Dim i As Long, AreaNum As Long

Dim MinR As Long, MinC As Long

AreaNum = Selection.Areas.count

ReDim SRange(1 To AreaNum)

MinR = ActiveSheet.Rows.count

MinC = ActiveSheet.Columns.count

For i = 1 To AreaNum

Set SRange(i) = Selection.Areas(i)

If SRange(i).Row < MinR Then MinR = SRange(i).Row

If SRange(i).Column < MinC Then MinC = SRange(i).Column

Next i

Set UPRange = Cells(SRange(1).Row, SRange(1).Column)

Set TRange = Application.InputBox(prompt:="选择粘贴区域的最左上角单元格", Title:="多区域复制粘贴", Type:=8)

Application.ScreenUpdating = False

For i = 1 To AreaNum

SRange(i).Copy

TRange.Offset(SRange(i).Row - MinR, SRange(i).Column - MinC).PasteSpecial Paste:=xlPasteValues

Next i

Application.ScreenUpdating = True

End Sub

二、批量提取批注

1.效果如下

将散落的批注，批量提取到指定区域

2.源码

需要根据实际情况修改区域

Sub test()
Application.ScreenUpdating = False
Dim i, j As Integer
Dim rg As Range
i = 2
For Each rg In Range("A5:BC20")
    If rg = "NG" Then
        For j = 1 To 7
        If Cells(4, rg.Column - j) = "穴号" Then
                col = rg.Column - j
        Exit For
        End If
        Next
        Cells(i, 68) = Cells(3, col).Value
        Cells(i, 69) = Cells(4, rg.Column).Value
        Cells(i, 70) = Cells(rg.Row, 1).Value
        Cells(i, 71) = rg.Comment.Text
        i = i + 1
    End If
Next

For Each rg In Range("A23:BC38")
    If rg = "NG" Then
        For j = 1 To 7
        If Cells(22, rg.Column - j) = "穴号" Then
                col = rg.Column - j
        Exit For
        End If
        Next
        Cells(i, 68) = Cells(21, col).Value
        Cells(i, 69) = Cells(22, rg.Column).Value
        Cells(i, 70) = Cells(rg.Row, 1).Value
        Cells(i, 71) = rg.Comment.Text
        i = i + 1
    End If
Next

For Each rg In Range("A41:BC56")
    If rg = "NG" Then
        For j = 1 To 7
        If Cells(40, rg.Column - j) = "穴号" Then
                col = rg.Column - j
        Exit For
        End If
        Next
        Cells(i, 68) = Cells(39, col).Value
        Cells(i, 69) = Cells(40, rg.Column).Value
        Cells(i, 70) = Cells(rg.Row, 1).Value
        Cells(i, 71) = rg.Comment.Text
        i = i + 1
    End If
Next

For Each rg In Range("A59:BC74")
    If rg = "NG" Then
        For j = 1 To 7
        If Cells(58, rg.Column - j) = "穴号" Then
                col = rg.Column - j
        Exit For
        End If
        Next
        Cells(i, 68) = Cells(57, col).Value
        Cells(i, 69) = Cells(58, rg.Column).Value
        Cells(i, 70) = Cells(rg.Row, 1).Value
        Cells(i, 71) = rg.Comment.Text
        i = i + 1
    End If
Next

For Each rg In Range("A77:BC100")
    If rg = "NG" Then
        For j = 1 To 7
        If Cells(76, rg.Column - j) = "穴号" Then
                col = rg.Column - j
        Exit For
        End If
        Next
        Cells(i, 68) = Cells(75, col).Value
        Cells(i, 69) = Cells(76, rg.Column).Value
        Cells(i, 70) = Cells(rg.Row, 1).Value
        Cells(i, 71) = rg.Comment.Text
        i = i + 1
    End If
Next

Application.ScreenUpdating = True
End Sub

---

总结

分享：
人，能真正坚持一辈子的东西太少了。世上的路有千万条，能够让我们选择的只有一条，你不可能同时在两条路上行走，选择适宜自己走的就好，别人走的不一定永远平坦，而你走的也不会永远曲折。