Question

我正在尝试编写代码，使我可以过滤非常大的一组数据（约10,000行），然后将过滤后的数据复制并粘贴到另一个工作表上。

最终，我尝试根据电话号码的左首数字进行过滤，然后再次使用5位数字进行过滤，依此类推，直到出现一行为止。并在列表框中显示每个粘贴的过滤结果。

Sub CopyPaste()

    Dim Data As Worksheet
    Dim Filtered As Worksheet
    Dim i As Long
    Dim row As Long
    Dim col As Integer
    col = 3
    Dim Copy As Range
    Dim Paste As Range

    Set Data = Sheets("Sheet1")
    Set Filtered = Sheets("Sheet2")

    For i = 2 To Sheet1.Range("A:A").End(xlUp).row

        If Left(Sheet1.Cells(i, 1), 4) = Me.ComboBox1.Value Then
            With Data
                Set Copy = .Range(.Cells(i, 1), .Cells(i, 3))
            End With 
            With Filtered
                Set Paste = .Range(.Cells(i, 1), .Cells(i, 3))
            End With
            Copy.Copy Destination:=Paste
        End If
    Next i 
End Sub

Private Sub ComboBox1_Change()
    Dim row As Integer
    Dim col As Integer
    Dim newRow As Integer 
        
    ' For ####
    If Len(Me.ComboBox1) = 4 Then
        Sheet1.Range("A2").AutoFilter _
          Field:=1, _
          Criteria1:=">" & ComboBox1.Value * 10 ^ 6, _
          Operator:=xlAnd, _
          Criteria2:="<" & ComboBox1.Value * 10 ^ 6 + 999999
     
        Call CopyPaste
    End If 
End Sub

从上面的代码来看，CopyPaste（）似乎根本不起作用。我可以根据电话号码的前4位数字进行过滤。

我被困在这里大约一个星期。任何帮助或教程链接将不胜感激。

Answer 1

此代码比您显示的代码长。但这似乎可以正常工作并且按预期运行（我希望如此）

Private Sub ComboBox1_Change()
    If Len(Me.ComboBox1) = 4 Then Call CopyPaste(Me.ComboBox1.Text)
End Sub

Sub CopyPaste(ByVal sSearch As String)
Dim wsData As Worksheet, wsFiltered As Worksheet ' Source and target worksheets
Dim rSearch As Range    ' Part of sheet for search subroutine
Dim rToCopy As Range    ' All cells with phone numbers by mask
Dim rCopy As Range, rPaste As Range ' Single cells - source and target
Rem Several decorating additives
Dim totalCells As Long, currentCell As Long
Dim prevPercent As Integer, currPercent As Integer

    Set wsData = Sheets("Sheet1")
    Set rSearch = Application.Intersect(wsData.Columns(1), wsData.UsedRange)
    Application.StatusBar = "Searching..."
    Set rToCopy = FindPhone(rSearch, sSearch & "??????") ' It is search by mask ####??????
    Application.StatusBar = False
    If rToCopy Is Nothing Then Exit Sub ' Not found
    
    totalCells = rToCopy.Cells.Count ' For status bar

    Set wsFiltered = Sheets("Sheet2")
    Set rSearch = wsFiltered.Columns(1) ' No need doubles, so will validate each before paste

    Set rPaste = wsFiltered.Cells(wsFiltered.Rows.Count, 1).End(xlUp) ' Last non-empty cell
    currentCell = 0: prevPercent = -1 ' decorating
    Application.ScreenUpdating = False
    For Each rCopy In rToCopy
Rem again decorating
        currentCell = currentCell + 1
        currPercent = 100 * currentCell / totalCells
        If prevPercent < currPercent Then
            prevPercent = currPercent
            Application.StatusBar = "Copy " & currentCell & " from " & totalCells & " (" & currPercent & "%)"
            DoEvents
        End If
Rem Is it unique phone number?
        If FindPhone(rSearch, rCopy.Text) Is Nothing Then
            Set rPaste = rPaste.Offset(1, 0) ' Shift down target cell
            rCopy.Resize(1, 3).Copy Destination:=rPaste ' Copy 3 cells
        End If
    Next rCopy
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Function FindPhone(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long, MaxCol As Long
    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
    
    Set FoundCell = SearchRange.Find(what:=FindWhat, _
            after:=LastCell, _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            MatchCase:=False)
    
    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False ' Loop forever. We'll "Exit Do" when necessary.
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If
        Loop
    End If
    Set FindPhone = ResultRange
End Function

将一系列单元格从一个工作表复制到另一个工作表

1 个答案: