0

我有一个包含 85,000 行的 excel 文件，我只需要提取单元格注释，但它目前太大，所以我想知道我是否可以编写一些 VB（以前从未做过）或宏或通过每一行的东西，查看是否有任何列有单元格注释，如果没有，则删除该行。

任何有关如何实现这一目标的提示将不胜感激！我有编程背景（很多很多年前做过一些 VB2-6，但从未为 Excel 编程过）

4

2 回答 2

2

这与您的要求略有不同，但我认为满足您的需求。它选择带有注释的行并将它们和第 1 行中的假定标题粘贴到另一个工作表中。更改“Sheet1”以适合：

Sub PasteRowsWithComments()
Dim wsSource As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim RowsWithComments As Excel.Range

Set wsSource = Sheet1
Set wsTarget = Worksheets.Add
On Error Resume Next
Set RowsWithComments = wsSource.Cells.SpecialCells(xlCellTypeComments).EntireRow
On Error GoTo 0
If Not RowsWithComments Is Nothing Then
    RowsWithComments.Copy Destination:=wsTarget.Range("A1")
    wsSource.Range("A1").EntireRow.Copy
    wsTarget.Range("A1").Insert shift:=xlDown
End If
End Sub

跟进

Option Explicit

Dim RngToCopy As Range

Sub PasteRowsWithComments()
    Dim wsSource As Excel.Worksheet
    Dim wsTarget As Excel.Worksheet
    Dim RowsWithComments As Excel.Range

    Set wsSource = Sheet1: Set wsTarget = Worksheets.Add

    On Error Resume Next
    Set RowsWithComments = wsSource.Cells.SpecialCells(xlCellTypeComments).EntireRow
    On Error GoTo 0

    If Not RowsWithComments Is Nothing Then
        '~~> This is required to clean duplicate ranges so that we do not get
        '~~> the error "That command cannot be used on multiple selections"
        If InStr(1, RowsWithComments.Address, ",") Then _
        Set RngToCopy = cleanRange(RowsWithComments) Else _
        Set RngToCopy = RowsWithComments

        RngToCopy.Copy Destination:=wsTarget.Rows(1)
        wsSource.Range("A1").EntireRow.Copy
        wsTarget.Range("A1").Insert shift:=xlDown
    End If
End Sub

'~~> This function will convert `$1:$1,$1:$1,$4:$4,$7:$7` to `$1:$1,$4:$4,$7:$7`
Function cleanRange(rng As Range) As Range
    Dim col As New Collection
    Dim Myarray() As String, sh As String, tmp As String
    Dim i As Long
    Dim itm As Variant

    sh = rng.Parent.Name: Myarray = Split(rng.Address, ",")

    For i = 0 To UBound(Myarray)
        On Error Resume Next
        col.Add Myarray(i), """" & Myarray(i) & """"
        On Error GoTo 0
    Next i

    For Each itm In col
        tmp = tmp & "," & itm
    Next

    tmp = Mid(tmp, 2): Set cleanRange = Sheets(sh).Range(tmp)
End Function
于 2012-08-08T22:39:31.260 回答
0

确保您的工作表处于活动状态，将“12”替换为您关心的列数numColumns。需要一些On Error技巧，HasComment()因为Comment.Text如果您在不存在时尝试检查其值，则会出现错误：

Sub RemoveRowsWithoutComments()
Dim rngAll As Range, rng As Range
Dim numColumns As Integer, colCntr As Integer, rowCntr As Long
Dim rowHasComment As Boolean

'set YOUR number of columns
numColumns = 12

Set rngAll = Range("A1", Range("A1").End(xlDown))

rowCntr = rngAll.Count - 1

'need to work backwards because deleting rows messes up forward iteration
Do Until rowCntr = -1

'work with current row (descending)
Set rng = Range("A1").Offset(rowCntr, 0)

rowHasComment = False

    For colCntr = 0 To numColumns

        If HasComment(rng.Offset(0, colCntr)) Then
            rowHasComment = True
            Exit For
        End If

    Next colCntr

    If Not rowHasComment Then rng.Rows.EntireRow.Delete

'decrement
rowCntr = rowCntr - 1
Loop
End Sub

Function HasComment(rng As Range) As Boolean
On Error GoTo NoComment

    If rng.Comment.Text <> "" Then
        HasComment = True
        Exit Function
    End If

NoComment:
    HasComment = False

End Function
于 2012-08-08T23:13:45.133 回答