12345
返回列表 上一主題 發帖

[發問] 轉換文字形式搜尋

wayne0303

帖子
86 
主題
15 
精華
0 
積分
148 
點名
54  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
註冊時間
2019-1-17 
最後登錄
2024-5-2 
34# 跳轉到 »
發表於 2021-9-13 08:02 | 只看該作者
回復 32# samwang


感謝samwang大!
我再試看看~

TOP

准提部林

帖子
2804 
主題
10 
精華
0 
積分
2860 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-2 
33#
發表於 2021-9-11 10:48 | 只看該作者
純文字處理~~~

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


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

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-4-29 
32#
發表於 2021-9-10 14:43 | 只看該作者
本帖最後由 samwang 於 2021-9-10 14:46 編輯

回復 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
....
...

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-4-29 
31#
發表於 2021-9-10 14:17 | 只看該作者
回復 30# wayne0303

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

TOP

wayne0303

帖子
86 
主題
15 
精華
0 
積分
148 
點名
54  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
註冊時間
2019-1-17 
最後登錄
2024-5-2 
30#
發表於 2021-9-10 13:38 | 只看該作者
本帖最後由 wayne0303 於 2021-9-10 13:44 編輯

回復 29# samwang

連結會變成...找不到(如附圖)
把檔案複製到桌面可以執行但搜尋結果是空白...
所以問一下大大~
R = Range("f65536").End(3).Row >>這是表格起始位置？所以您這個代碼沒有設定表格搜尋範圍了？
Arr = Range("a1:a" & [a65536].End(3).Row)>>這是來源配對檔位置？

因為您這個代碼是設定連結外部表格搜尋，如果我要先用本身檔案測試與了解之後再套用外部的表格...那該改哪邊呢？

謝謝

2021-09-10_133023_New.jpg (19.97 KB)

2021-09-10_133023_New.jpg

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-4-29 
29#
發表於 2021-9-10 11:45 | 只看該作者
回復 28# wayne0303

請測試看看，謝謝

Sub test()
Dim Arr, xD, T1$, T2$, T$, w1$, w2$, i&, j&, k%, R%, C%
Set xD = CreateObject("Scripting.Dictionary")
Set fs = CreateObject("Scripting.FileSystemObject")
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
    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
    If Left(Arr(i, 1), 1) = "L" Or Left(Arr(i, 1), 1) = "R" Then
        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
            If UCase(w1) = "L" Then
                T1 = Mid(Split(Arr(i, 1), "仰")(0), 2)
                T2 = Split(Split(Arr(i, 1), "角")(1), "°")(0)
                T = T1 & "/" & T2 & "_" & 2: Arr(i, 1) = xD(T)
            End If
            If UCase(w1) = "R" Then
                T1 = Mid(Split(Arr(i, 1), "仰")(0), 2)
                T2 = Split(Split(Arr(i, 1), "角")(1), "°")(0)
                T = T1 & "/" & T2 & "_" & 1: Arr(i, 1) = xD(T)
            End If
        Else
            T = Split(Arr(i, 1), "轉")(0) & "_" & 3: Arr(i, 1) = xD(T)
        End If
    End If
98: Next
Range("b1").Resize(UBound(Arr)) = Arr
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

TOP

wayne0303

帖子
86 
主題
15 
精華
0 
積分
148 
點名
54  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
註冊時間
2019-1-17 
最後登錄
2024-5-2 
28#
發表於 2021-9-10 10:54 | 只看該作者
回復 27# samwang


  我就是把這邊的路徑改成公司的區網裡的檔案路徑而已Set WB = Workbooks.Open("公司路徑")
>>如您寫的Set WB = Workbooks.Open("公司路徑")，公司路徑就換成實際的路徑即可>>公司路徑就是檔案放置的位置
>> 檔名是......\活頁簿abc.xlsx，對嗎?  >> 檔名是......\○○○統計表.xlsx ←這樣

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-4-29 
27#
發表於 2021-9-10 09:34 | 只看該作者
回復 26# wayne0303

我就是把這邊的路徑改成公司的區網裡的檔案路徑而已Set WB = Workbooks.Open("公司路徑")
>>如您寫的Set WB = Workbooks.Open("公司路徑")，公司路徑就換成實際的路徑即可>>公司路徑就是檔案放置的位置
>> 檔名是......\活頁簿abc.xlsx，對嗎?

TOP

wayne0303

帖子
86 
主題
15 
精華
0 
積分
148 
點名
54  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
註冊時間
2019-1-17 
最後登錄
2024-5-2 
26#
發表於 2021-9-10 08:19 | 只看該作者
回復 25# samwang

我的欄列都會(不對等的)增加
>>請問您的資料是從K欄開始嗎? 3個資料的中間不會有其它的資料對吧?>>如附件，實際是從D欄開始

我就是把這邊的路徑改成公司的區網裡的檔案路徑而已Set WB = Workbooks.Open("公司路徑")
>>如您寫的Set WB = Workbooks.Open("公司路徑")，公司路徑就換成實際的路徑即可>>公司路徑就是檔案放置的位置

轉換文字形式搜尋_例1.rar (18.51 KB)

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-4-29 
25#
發表於 2021-9-9 20:30 | 只看該作者
回復 24# wayne0303

我的欄列都會(不對等的)增加
>>請問您的資料是從K欄開始嗎? 3個資料的中間不會有其它的資料對吧?

我就是把這邊的路徑改成公司的區網裡的檔案路徑而已Set WB = Workbooks.Open("公司路徑")
>>如您寫的Set WB = Workbooks.Open("公司路徑")，公司路徑就換成實際的路徑即可

TOP

        靜思自在 : 不要隨心所欲，要隨心教育自己。
12345
返回列表 上一主題