jcchiang

回復 1# BV7BW

試試看
  Sub ex()
Dim arr As Variant, a As Object, X%
Set arr = Sheets("工作表3").Range(Sheets("工作表3").[F2], Sheets("工作表3").[d2].End(4))
With Sheets("工作表2")
   For Each a In .Range(.[a4], .[a4].End(4))
      For X = 1 To arr.Rows.Count
         If a = Int(Replace(arr(X, 1), "A", "") - 100) Then
            a.Offset(, 1).Resize(, 3) = Application.Transpose(Application.Transpose(arr(X, 1).Resize(, 3)))
            Exit For
         End If
      Next
   Next
End With
End Sub

jcchiang

回復 7# BV7BW

原程式測試時並無當機問機,所以不了解你所說會當機是什麼問題
只是原程式不知道判斷條件是以Sheets("工作表2").[C2]為主
修改後程式如下
  Sub ex()
Dim X$, a As Variant, c As Variant
Set c = Nothing
Sheets("工作表2").Range([b4], [b4].End(4).Resize(, 3)).ClearContents
X = Sheets("工作表2").[C2]
For Each a In Sheets("工作表3").Range([工作表3!D2], [工作表3!D2].End(4))
   If a = X Or a.Offset(, 1) Like "*" & X & "*" Or a.Offset(, 2) = X Then  '判斷是否有符合條件
      If c Is Nothing Then
         Set c = a.Resize(, 3)
      Else
         Set c = Union(c, a.Resize(, 3))
      End If
   End If
Next
c.Copy Sheets("工作表2").[b4].Resize(, 3)
End Sub

jcchiang

回復 20# BV7BW
1.關鍵字查詢並沒有提到編號只會輸入"A",所以項編是以全相符比對
   請將If a = X Or a.Offset(, 1) Like "*" & X & "*" Or a.Offset(, 2) = X Then
   改為 If Join(Application.Transpose(Application.Transpose(a.Resize(, 3))), "") Like "*" & X & "*" Then  '把Sheets(3) D~F欄字串合併做模糊比對
2.Sheets("工作表2").Range([b4], [b4].End(4).Resize(, 3)).ClearContents '清除資料
是依所提供的資料去寫的,如果實際工作表有不一樣請自行修改
3.工作表3中"A""B""C"欄是原提供資料就有的,程式中並無使用

jcchiang

回復 23# BV7BW

可以多加一個判斷,當C有資料才去執行資料寫入
If Not c Is Nothing Then c.Copy Sheets("工作表2").[B4].Resize(, 3)