Question

我希望过滤并将数据从主要的Excel电子表格（表单1）移动到新的表单（表2），但到目前为止我发现的所有建议都只涉及过滤一列数据，我想移动两个。我还需要通过通配符过滤。

我附上了我的工作表1的图像，以及我希望在工作表2中创建的内容。

A栏是日期; B列是动物类型; C列是重量。

我需要通过通配符过滤才能找到所有的马匹＃39;在B列中，然后将日期，动物类型和重量移动到电子表格2。

我设法使用

完成了第一部分

insert into table extConTable <select_query>

但我仍然坚持删除所有空白行的第二部分。

Animal weights

Answer 1

试试这个

Option Explicit

Sub horses()

With Worksheets("Sheet1").Range("B2:D100") '<== range containing data, headers included
    .Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    .AutoFilter field:=2, Criteria1:="*Horse"
    If WorksheetFunction.Subtotal(103, .Cells) > .Columns.Count Then
        .SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Sheet2").Range("A1") '<== copying form cell "A1" of "Sheet2"
    End If
End With

End Sub

根据您的需要调整评论行

Answer 2

使用以下功能获取结果。您可以解析此函数的任何内容，以便在Sheet2中获得结果。

Private Function filtercontent(content As String) As String
    Lastrow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To Lastrow
        If InStr(Cells(i, 2), content) > 0 Then
            Worksheets("Sheet1").Range("A" & i, "C" & i).Copy
            With Worksheets("Sheet2")
                .Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
            End With
        End If
    Next i
End Function

或

Private Function filtercontent(content As String) As String
    Dim Lastrow As Long
    Dim i As Integer
    Lastrow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To Lastrow
        If InStr(Cells(i, 2), content) > 0 Then
            Worksheets("Sheet1").Range("A" & i, "C" & i).Copy Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
        End If
    Next i
End Function

例如，如果您想要为马应用过滤器

Sub testing()
    filtercontent ("Horse")
End Sub

过滤值并将数据复制到新工作表

2 个答案: