將一系列單元格從一個工作表復制到另一個工作表

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