我如何刪除任何列中沒有任何單元格註釋的行，在Excel 2010電子表格中

Question

我有一個包含85,000行的excel文件，我只需要提取單元格註釋，但它目前太大，所以我想知道我是否可以編寫一些VB（以前從未做過）或者是一個宏，或者是每一行的內容，看看是否有列有單元格註釋，如果沒有，則刪除行。

任何提示如何實現這一點，將不勝感激！我有一個編程背景（並且在很多年前做了很多VB2-6，但從未爲Excel編程過）

Answer 1

確保您的表處於活動狀態，與您關心與numColumns列數代替 「12」。

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 

Answer 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