将一些行复制到另一张纸上

Question

我有一个包含搜索引擎的表格。键入搜索后；您的搜索条件将生成一个过滤器。 筛选出结果后，我想在这里做什么；我希望用户选择一些行以将其复制到另一张纸上。 我正在考虑为每一行（在过滤器之前）创建一个复选框。然后从过滤的结果中，用户将检查需要复制的行。但是我不知道要这样做的代码。 你能帮我吗？ 我希望我的解释清楚。否则，请让我知道详细说明。

这是搜索框：

    Sub SearchBox()
'PURPOSE: Filter Data on User-Determined Column & Text/Numerical value
'SOURCE: www.TheSpreadsheetGuru.com

Dim myButton As OptionButton
Dim SearchString As String
Dim ButtonName As String
Dim sht As Worksheet
Dim myField As Long
Dim DataRange As Range
Dim mySearch As Variant

'Load Sheet into A Variable
  Set sht = ActiveSheet

'Unfilter Data (if necessary)
  On Error Resume Next
    sht.ShowAllData
  On Error GoTo 0

'Filtered Data Range (include column heading cells)
  Set DataRange = sht.Range("A7:D1000") 'Cell Range
  'Set DataRange = sht.ListObjects("Table 2").Range 'Table

'Retrieve User's Search Input
  mySearch = sht.Shapes("UserSearch").TextFrame.Characters.Text 'Control Form
  'mySearch = sht.OLEObjects("UserSearch").Object.Text 'ActiveX Control
  'mySearch = sht.Range("A1").Value 'Cell Input

'Determine if user is searching for number or text
  If IsNumeric(mySearch) = True Then
    SearchString = "=" & mySearch
  Else
    SearchString = "=*" & mySearch & "*"
  End If

'Loop Through Option Buttons
  For Each myButton In sht.OptionButtons
    If myButton.Value = 1 Then
      ButtonName = myButton.Text
      Exit For
    End If
  Next myButton

'Determine Filter Field
  On Error GoTo HeadingNotFound
    myField = Application.WorksheetFunction.Match(ButtonName, DataRange.Rows(1), 0)
  On Error GoTo 0

'Filter Data
  DataRange.AutoFilter _
    Field:=myField, _
    Criteria1:=SearchString, _
    Operator:=xlAnd

'Clear Search Field
  sht.Shapes("UserSearch").TextFrame.Characters.Text = "" 'Control Form
  'sht.OLEObjects("UserSearch").Object.Text = "" 'ActiveX Control
  'sht.Range("A1").Value = "" 'Cell Input

Exit Sub

'ERROR HANDLERS
HeadingNotFound:
  MsgBox "The column heading [" & ButtonName & "] was not found in cells " & DataRange.Rows(1).Address & ". " & _
    vbNewLine & "Please check for possible typos.", vbCritical, "Header Name Not Found!"

End Sub

这是为了清除文件管理器：

Sub ClearFilter()
'PURPOSE: Clear all filter rules

'Clear filters on ActiveSheet
  On Error Resume Next
    ActiveSheet.ShowAllData
  On Error GoTo 0

Answer 1

出于演示目的，我将继续假设您的数据设置如下：

正在从您现有的代码中过滤数据。

我已经添加了您建议的复选框，每行一个。

要使以下代码正常工作，请确保复选框为Form Controls，而不是ActiveX controls，这一点很重要。

至关重要的是，必须为每个复选框激活Move and size with cells选项。这会将复选框与您所放置的单元格“绑定”在一起，这意味着当相应的行被过滤掉时，该复选框也将被隐藏。

Sub copySelected()
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Dim sourceRng As Range
Dim cb As CheckBox
Set shtSource = ThisWorkbook.Worksheets("Name of Source Worksheet") 'where the data is
Set shtDestination = ThisWorkbook.Worksheets("Name of Destination Worksheet") 'where the selected rows should be copied
For Each cb In shtSource.CheckBoxes 'loop through all the checkboxes
    If cb.Value = 1 Then 'if the checkbox has been selected by the user then...
        shtSource.Range("B" & cb.TopLeftCell.Row, "D" & cb.TopLeftCell.Row).Copy '...copy the corresponding range of data...
        With shtDestination
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues '...and paste it to the first empty row in the destination sheet
        End With
    End If
Next cb
End Sub