試試看
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作者: samwang 時間: 2021-3-25 11:49
請測試看看，謝謝。
Sub tt()
Dim Arr, xD, i&, N%, T
Set xD = CreateObject("Scripting.Dictionary")
Sheets("工作表2").Range("b4:d200") = ""
Arr = Range([工作表3!F1], [工作表3!D65536].End(3))
For i = 2 To UBound(Arr)
T = Int(Replace(Arr(i, 1), "A", "") - 100)
xD(T & "") = Array(Arr(i, 1), Arr(i, 2), Arr(i, 3))
Next
Arr = Range([工作表2!D3], [工作表2!A65536].End(3))
For i = 2 To UBound(Arr)
If xD.Exists(Arr(i, 1) & "") Then
Arr(i, 2) = xD(Arr(i, 1) & "")(0)
Arr(i, 3) = xD(Arr(i, 1) & "")(1)
Arr(i, 4) = xD(Arr(i, 1) & "")(2)
N = N + 1
End If
Next
If N > 0 Then Sheets("工作表2").[A3].Resize(N, 4) = Arr
End Sub作者: BV7BW 時間: 2021-3-25 12:51
請再測試看看，感謝。
Sub tt1()
Dim Arr, i&, N%, T, pos%, pos2%, pos3%
Sheets("工作表2").Range("A4:D1000") = ""
T = [工作表2!C2]
Arr = Range([工作表3!G1], [工作表3!D65536].End(3))
For i = 2 To UBound(Arr)
pos = InStr(Arr(i, 1), T): pos2 = InStr(Arr(i, 2), T)
pos3 = InStr(Arr(i, 3), T)
If pos > 0 Or pos2 > 0 Or pos3 > 0 Then
N = N + 1: Arr(N, 1) = Format(N, "00")
For j = 2 To 4: Arr(N, j) = Arr(i, j - 1): Next
End If
Next
If N > 0 Then
With Sheets("工作表2")
.Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@"
.[A4].Resize(N, 4) = Arr
End With
End If
End Sub作者: BV7BW 時間: 2021-3-28 19:13
Sub tt1()
Dim Arr, i&, N%, T, pos%, pos2%, pos3%
Sheets("工作表2").Range("A4:D1000") = "" '清除工作表2的資料
T = [工作表2!C2] '查找字
Arr = Range([工作表3!G1], [工作表3!D65536].End(3)) '將工作表3資料D~G欄位資料放在數組中
For i = 2 To UBound(Arr)
pos = InStr(Arr(i, 1), T): pos2 = InStr(Arr(i, 2), T)
pos3 = InStr(Arr(i, 3), T) '查詢字確認有無在工作表3的D、E、F欄
If pos > 0 Or pos2 > 0 Or pos3 > 0 Then '有找到時
N = N + 1: Arr(N, 1) = Format(N, "00") '有資料時Arr的第1欄位，自動產生序號
For j = 2 To 4: Arr(N, j) = Arr(i, j - 1): Next '將工作表3資料D、E、F欄資料暫時存放在Arr
End If
Next
If N > 0 Then '確認有無找到資料
With Sheets("工作表2")
.Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@" 'A欄改為文字格式
.[A4].Resize(N, 4) = Arr '有找到資料救回填至工作表2
End With
End If
End Sub作者: jcchiang 時間: 2021-3-29 08:50
原程式測試時並無當機問機,所以不了解你所說會當機是什麼問題
只是原程式不知道判斷條件是以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作者: BV7BW 時間: 2021-3-29 09:12
回復 16#samwang
感謝 S 大大先進 勞心指導 謝謝你
現整組程式已完全可理解也可正常運作
先前不能保護動作.以加上鎖定即解除動作.如下
Sub tt1()
Worksheets("工作表2").Unprotect ("0123") '保護工作表2
Dim Arr, i&, N%, T, pos%, pos2%, pos3%
Sheets("工作表2").Range("A4:D1000") = "" '清除工作表2的資料
T = [工作表2!C2] '查找字
Arr = Range([工作表3!G1], [工作表3!D65536].End(3)) '將工作表3資料D~G欄位資料放在數組中
For i = 2 To UBound(Arr)
pos = InStr(Arr(i, 1), T): pos2 = InStr(Arr(i, 2), T)
pos3 = InStr(Arr(i, 3), T) '查詢字確認有無在工作表3的D、E、F欄
If pos > 0 Or pos2 > 0 Or pos3 > 0 Then '有找到時
N = N + 1: Arr(N, 1) = Format(N, "00") '有資料時Arr的第1欄位，自動產生序號
For j = 2 To 4: Arr(N, j) = Arr(i, j - 1): Next '將工作表3資料D、E、F欄資料暫時存放在Arr
End If
Next
If N > 0 Then '確認有無找到資料
With Sheets("工作表2")
.Range(.[A4], .Cells(N + 3, 1)).NumberFormatLocal = "@" 'A欄改為文字格式
.[A4].Resize(N, 4) = Arr '有找到資料救回填至工作表2
End With
End If
Sheets("工作表2").Protect ("0123") '取消保護工作表2
End Sub作者: BV7BW 時間: 2021-3-29 09:23
回復 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"欄是原提供資料就有的,程式中並無使用作者: BV7BW 時間: 2021-3-30 12:40
