wayne0303

回復 20# samwang




非常感謝samwang大大 不厭其煩的幫忙！

wayne0303

回復 20# samwang

samwang大 又有問題了~
我的欄列都會(不對等的)增加
我修改了代碼(紅字)範圍部分但好像沒作用...
應該要再改哪邊呢？

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

還有連結外部表格的時候會出現執行階段錯誤'1004':

謝謝

samwang

回復 22# wayne0303

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

wayne0303

回復 23# samwang

回復  wayne0303

我的欄列都會(不對等的)增加 >> 可以提供實際案例範例，且說明何謂不對等增加? 謝謝
,                                     ↑↑↑不好意思我是指工作上會需要增加
...
samwang 發表於 2021-9-9 17:31

還有連結外部表格的時候會出現執行階段錯誤'1004':  >> 請提供範例，謝謝
    我就是把這邊的路徑改成公司的區網裡的檔案路徑而已Set WB = Workbooks.Open("公司路徑")，這個我也不知道怎麼提供範例...不能解就這樣吧

謝謝samwang大~

samwang

回復 24# wayne0303

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

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

wayne0303

回復 25# samwang

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

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

samwang

回復 26# wayne0303

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

wayne0303

回復 27# samwang


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

wayne0303

回復 29# samwang

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

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

謝謝