在Excel 2010电子表格中，如何删除任何列中没有单元格注释的行
我有一个85000行的Excel文件，我只需要提取单元格的注释，但它目前太大了，所以我想知道如果我可以写一些VB（从来没有做过之前）或macros或什么，通过每一行，查看是否有任何列有单元格注释，如果没有，则删除该行。
任何提示如何实现这一点，将不胜感激！ 我有一个编程背景（并且在很多年前做了许多VB2-6，但是从来没有为Excel编写过程）
确保您的工作表处于活动状态，请将“12”replace为您为numColumns所关注的列数。 HasComment()需要一些On Error trickery，因为如果您尝试在不存在的情况下检查其值，则会出现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
这与你所要求的略有不同，但我认为可以满足你的需求。 它select带有注释的行并将它们粘贴，并将行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