samwang

回復 30# wayne0303

因為您這個代碼是設定連結外部表格搜尋，如果我要先用本身檔案測試與了解之後再套用外部的表格...那該改哪邊呢？
>> #20 就有說明過了，下面那3個移除即可
'FPath = ThisWorkbook.Path
'Set WB = Workbooks.Open(FPath & "\統計表.xlsx")
...
...
'WB.Close

samwang

回復 30# wayne0303


R = Range("f65536").End(3).Row >>這是表格起始位置？所以您這個代碼沒有設定表格搜尋範圍了？
Arr = Range("a1:a" & [a65536].End(3).Row)>>這是來源配對檔位置？   
>> #29 程式碼，只有針對你提到"我的欄列都會(不對等的)增加" 做修改如下，還有比對時一小部分新增，已有寫註解了，請自行研究一下，謝謝

Application.ScreenUpdating = False: Application.DisplayAlerts = False
'FPath = ThisWorkbook.Path  '本檔案的路徑
'Set WB = Workbooks.Open(FPath & "\統計表.xlsx") '開啟本檔案路徑下的統計表
'''針對"我的欄列都會(不對等的)增加"的處理，
With Sheets(1)
    If .FilterMode Then .ShowAllData
    R = Range("f65536").End(3).Row  'F欄最後一列
    C = Rows("3:" & R).Find("*", searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column '找到最後一欄
    Arr = Range([f1], Cells(R, C)) '資料裝入陣列
    For i = 1 To UBound(Arr)
        If InStr(Arr(i, 1), "右螺") Then
            For j = 1 To UBound(Arr, 2)
                T = Arr(i + 2, j): If T = "" Then GoTo 95
                xD(T & "_1") = Arr(i + 1, j)   '右螺旋資料裝到字典
95:         Next
        ElseIf InStr(Arr(i, 1), "左螺") Then
            For j = 1 To UBound(Arr, 2)
                T = Arr(i + 2, j): If T = "" Then GoTo 96
                xD(T & "_2") = Arr(i + 1, j)    '左螺旋資料裝到字典
96:         Next
        ElseIf InStr(Arr(i, 1), "平") Then
            For j = 1 To UBound(Arr, 2)
                T = Arr(i + 2, j): If T = "" Then GoTo 97
                xD(T & "_3") = Arr(i + 1, j)    '平彎資料裝到字典
97:         Next
        End If
    Next
End With
'WB.Close   '關閉統計表

'下面的上次的一樣，只有新增如下
Arr = Range("a1:a" & [a65536].End(3).Row) '要被比對的資料
For i = 1 To UBound(Arr)
    If Arr(i, 1) = "" Then GoTo 98 '新增:當A欄的儲存格無資料不做動作
    If Left(Arr(i, 1), 1) = "L" Or Left(Arr(i, 1), 1) = "R" Then 'A欄儲存格的第1個字"L" "R"才動作
        w1 = Left(Arr(i, 1), 1): w2 = Mid(Arr(i, 1), 2, 1)
        If Asc(w1) > 64 And Asc(w1) < 123 And Asc(w2) > 64 And Asc(w2) < 123 Then
....
...

准提部林

純文字處理~~~

Sub TEST_A1()
Dim xU As Range, Arr, A, V, xR As Range, xD, T$
Set xD = CreateObject("Scripting.Dictionary")
Set xU = [工作表1!d:w] '若是跨檔, 必須先打開該檔案, 再指定工作表及範圍
For Each A In Array("平彎", "右螺旋", "左螺旋")     
      For Each xR In xU.Find(A, Lookat:=xlWhole).MergeArea   '注意:這是以"合併格"抓範圍
           xD(V & xR(3)) = xR(2)
    Next
    V = V + 1
Next
'---------------------------
Arr = Range([a1], [a65536].End(3))
For i = 5 To UBound(Arr)
    T = Replace(Replace(Arr(i, 1), "°", ""), "仰角", "/")
    T = Split(Replace(Replace(T, "RR", "1R"), "LR", "2R") & "轉", "轉")(0)
    Arr(i - 4, 1) = xD(T)
Next i
[b5].Resize(UBound(Arr) - 4) = Arr
End Sub


================================

wayne0303

回復 32# samwang


感謝samwang大!
我再試看看~

wayne0303

回復 33# 准提部林


For Each xR In xU.Find(A, Lookat:=xlWhole).MergeArea   '注意:這是以"合併格"抓範圍>>可是准大這樣還必須複製到其它地方合併，比較希望能用原表格型式搜尋...

wayne0303

回復 33# 准提部林


准大我試了您的代碼只搜出最後一個R390的品號，再麻煩您有空看一下是我範圍設錯了嗎？
然後請忽略35#的發言~


謝謝~

准提部林

回復 36# wayne0303

Sub TEST_A1()
Dim xU As Range, Arr, A, V, xR As Range, xD, T$
Set xD = CreateObject("Scripting.Dictionary")
Set xU = [工作表1!f2:ad73]
For Each A In Array("平彎", "右螺旋", "左螺旋")
    For Each xR In xU.Find(A, Lookat:=xlWhole).Resize(1, 100)  '找到關鍵字, 向右擴展100欄, 若不夠用自改下(此時就不用管合併格了)  
        If xR(3) <> "" Then xD(V & xR(3)) = xR(2)
    Next
    V = V + 1
Next
'---------------------------
Arr = Range([a1], [a65536].End(3))
For i = 1 To UBound(Arr)  'A欄資料由第一行開始, 要改成 FOR I=1 TO ??   
    T = Replace(Replace(Arr(i, 1), "°", ""), "仰角", "/")
    T = Split(Replace(Replace(T, "RR", "1R"), "LR", "2R") & "轉", "轉")(0)
    Arr(i, 1) = xD(T) '同行寫入, 這就不須再用 i-4   
Next i
[b1].Resize(UBound(Arr)) = Arr  '結果資料置入, 須同步從B1下手   
End Sub


==========================================

wayne0303

回復 37# 准提部林


報告准大~內部表格可以，但……

Set xU = [工作表1!d:w] '若是跨檔, 必須先打開該檔案, 再指定工作表及範圍 >>跨檔這個照您說的打開該檔，也指定工作表名稱跟範圍測試會出現'424吔...

准提部林

回復 38# wayne0303

參考檔:
TEST001.rar (27.31 KB)

下載次數: 7

2021-9-14 10:35

wayne0303

回復 39# 准提部林


准大，我照改馬塞克部分，就變成這樣了...
(100是夠用的)