samwang

回復 1# wayne0303

不好意思看不太懂，可否解釋詳細一點，謝謝

samwang

回復 3# wayne0303

請測試看看，謝謝

Sub test()
Dim Arr, xD, T$, w1$, w2$, i&, j&, k%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range("d3:w16")
For i = 2 To UBound(Arr) Step 6
    k = k + 1
    For j = 1 To UBound(Arr, 2)
        T = Arr(i, j): If T = "" Then GoTo 99
        xD(T & "_" & k) = Arr(i - 1, j)
    Next j
99: Next i
Arr = Range("a5:a" & [a5].End(4).Row)
For i = 1 To UBound(Arr)
    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
            T = Mid(Arr(i, 1), 2, 4) & "/" & Mid(Arr(i, 1), 8, 2) & "_" & 2
            Arr(i, 1) = xD(T)
        End If
        If UCase(w1) = "R" Then
            T = Mid(Arr(i, 1), 2, 4) & "/" & Mid(Arr(i, 1), 8, 2) & "_" & 1
            Arr(i, 1) = xD(T)
        End If
    Else
        T = Left(Arr(i, 1), 4) & "_" & 3
        Arr(i, 1) = xD(T)
    End If
Next
Range("b5").Resize(UBound(Arr)) = Arr
End Sub

samwang

回復  samwang

報告samwang大！
  我執行完沒東西吔...

R是3~4位數字
wayne0303 發表於 2021-8-30 23:54

如附件圖片，我執行沒問題依據4#程式碼，結果在B欄，請再確認，謝謝。

samwang

回復 13# wayne0303

請再測試看看，謝謝

   1.如圖現在遇到仰角是個位數字跟R為4位數字就搜尋不到  >> 已更新如附件
   2.如果我的表格是必需引用到外部的表格那我要改代碼的哪邊呢？ >> 程式碼有備註需要更改的地方(第1段)
   3.用"模組"的話有辦法按個滑鼠的右鍵或左鍵就更新數值 或是 數值有變更就可立即更新數值(不需關掉檔案再開)？  >>已更新，當A5~A65536有更新會自動更新

samwang

回復  samwang


samwang大大~

2.如果我的表格是必需引用到外部的表格那我要改代碼的哪邊呢？ 這個 ...
wayne0303 發表於 2021-8-31 19:37

修改如紅字部分，請測試看看，謝謝
Sub 更新()
Dim Arr, xD, T1$, T2$, T$, w1$, w2$, i&, j&, k%
Set xD = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WB = Workbooks.Open("D:\資料夾123\活頁簿abc.xlsx")
Arr = Range("d3:w16")
WB.Close

For i = 2 To UBound(Arr) Step 6
    k = k + 1
    For j = 1 To UBound(Arr, 2)
        T = Arr(i, j): If T = "" Then GoTo 99
        xD(T & "_" & k) = Arr(i - 1, j)
    Next j
99: Next i
....
...
....

samwang

回復 22# wayne0303

我的欄列都會(不對等的)增加 >> 可以提供實際案例範例，且說明何謂不對等增加? 謝謝
   
還有連結外部表格的時候會出現執行階段錯誤'1004':  >> 請提供範例，謝謝

samwang

回復 24# wayne0303

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

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

samwang

回復 26# wayne0303

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

samwang

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

samwang

回復 30# wayne0303

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