VBA，使用Find匹配和复制数据。卡在循环中

Question

我附上了一张图片，显示了我的数据以及我想要实现的目标。

我的代码无法正常运行。它复制了14和bb1的数据，然后它被卡在循环中。请帮我纠正。

为什么我想使用find方法是，在H行中为ex，我将有大约20到30个id匹配1000行..所以循环整行将花费很长时间。

任何想法如何纠正和优化代码。感谢

Sub Findandcopy()

    Dim shtOld As Worksheet, shtNew As Worksheet
    Dim oldRow As Integer
    Dim newRow As Integer
    Dim i As Integer, id, f As Range
    Dim g As Range
    Dim currow As Long

    Set shtOld = ThisWorkbook.Sheets("Sheet1")
    Set shtNew = ThisWorkbook.Sheets("Sheet2")


With shtOld.Range("H1:H30")
    Set c = .find("*")

    If Not c Is Nothing Then
        firstAddress = c.Address

        Do


            Set f = shtNew.Range("G2:G40").find(c)

            If Not f Is Nothing Then

                    currow = f.Cells.Row
                    shtNew.Activate
                    Set g = shtNew.Range("G" & currow).Resize(4, 2)
                    g.Copy
                    shtOld.Activate
                    shtOld.Range("I" & c.Row).Select
                    ActiveSheet.Paste

            End If



            Set c = .FindNext("*")

            Loop While Not c Is Nothing And c.Address <> firstAddress

    End If
End With


End Sub

Answer 1

这就是我提出的......我没有使用查找和替换，只需简单地循环浏览两个源表中的值。我已经对代码进行了评论，因此应该很容易看到它正在做什么。

我已经对它进行了测试，并且它处理了我从您提供的屏幕上复制的一些数据。

---

Sub Findandcopy()

Dim sourceSht1 As Worksheet _
, sourceSht2 As Worksheet _
, destinationSht As Worksheet

Dim sourceValue As String
Dim endRow As Long

Dim counter As Integer

Set sourceSht1 = Sheet1
Set sourceSht2 = Sheet2
Set destinationSht = Sheet3

On Error GoTo Err

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'get the end row of sourceSht2 (column H)
endRow = sourceSht2.Range("H" & sourceSht2.UsedRange.Count + 1).End(xlUp).Row


    'loop backwards as the sourceSht1 value that we want to get is after the beginning
    For i = endRow To 1 Step -1

    counter = counter + 1

    'get value from sourceSht 1
    If sourceSht1.Cells(i, 8).Value <> "" Then _
    sourceval = sourceSht1.Cells(i, 8).Value

    'we always copy the number from sourceSht2
    destinationSht.Cells(i, 10).Value = sourceSht2.Cells(i, 8).Value

            'if the counter is 4 then we've reached the top of the list
            If counter = 4 Then

            'value in column G is always at the top of the section (sourceSht2)
            destinationSht.Cells(i, 9).Value = sourceSht2.Cells(i, 8).Value

            'copy the value we stored from sourceSht1 (set number format to text)
            destinationSht.Cells(i, 8).NumberFormat = "@"
            destinationSht.Cells(i, 8).Value = sourceval


            'reset sourceval in case next section doesn't have any value in column H
            sourceval = ""

            'reset counter
            counter = 0

            End If
    Next i


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


Exit Sub

Err:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub