Board logo

標題: [發問] A資料庫依原則轉置B資料庫-問題尋問 [打印本頁]
作者: rouber590324    時間: 2020-7-9 11:48     標題: A資料庫依原則轉置B資料庫-問題尋問

DEAR ALL 大大
1.A資料庫依原則轉置B資料庫-問題尋問 說明如下 (公司電腦-無法上傳檔案SORRY)
2.SHEET1 資料如下
RANGE("A1")=NET10        RANGE("B1")=A01     RANGE("C1")=1        RANGE("D1")=1
RANGE("A2")=NET10        RANGE("B2")=A02     RANGE("C2")=2        RANGE("D2")=2  
RANGE("A3")=NET10        RANGE("B3")=A01     RANGE("C3")=3        RANGE("D3")=3  
RANGE("A4")=NET10        RANGE("B4")=A03     RANGE("C4")=4        RANGE("D4")=4  
RANGE("A5")=NET10        RANGE("B5")=A20     RANGE("C5")=5        RANGE("D5")=5  
RANGE("A6")=NET13        RANGE("B6")=A01     RANGE("C6")=6        RANGE("D6")=6  
RANGE("A7")=NET13        RANGE("B7")=A01     RANGE("C7")=7        RANGE("D7")=7  
RANGE("A8")=NET13        RANGE("B8")=A01     RANGE("C8")=8        RANGE("D8")=8  
RANGE("A9")=NET13        RANGE("B9")=A01     RANGE("C9")=9        RANGE("D9")=9  
RANGE("A10")=NET13      RANGE("B10")=A20   RANGE("C10")=10   RANGE("D10")=10  
2.1 原則1  A欄同內容為同一組 (例 :  NET10為同一組 NET13為同一組 )
      原則2  B欄 A01為主KEY. 與 非A01 配組轉置新SHEET2.
3.SHEET2 結果資料如下
3.1 NET10有2組 A01 3組非A01   故如下
RANGE("A1")=NET10        RANGE("B1")=A01     RANGE("C1")=1        RANGE("D1")=1
RANGE("A2")=NET10        RANGE("B2")=A02     RANGE("C2")=2        RANGE("D2")=2  
RANGE("A1")=NET10        RANGE("B1")=A01     RANGE("C1")=1        RANGE("D1")=1
RANGE("A4")=NET10        RANGE("B4")=A03     RANGE("C4")=4        RANGE("D4")=4
RANGE("A1")=NET10        RANGE("B1")=A01     RANGE("C1")=1        RANGE("D1")=1
RANGE("A5")=NET10        RANGE("B5")=A20     RANGE("C5")=5        RANGE("D5")=5
RANGE("A3")=NET10        RANGE("B3")=A01     RANGE("C3")=3        RANGE("D3")=3
RANGE("A2")=NET10        RANGE("B2")=A02     RANGE("C2")=2        RANGE("D2")=2  
RANGE("A3")=NET10        RANGE("B3")=A01     RANGE("C3")=3        RANGE("D3")=3
RANGE("A4")=NET10        RANGE("B4")=A03     RANGE("C4")=4        RANGE("D4")=4
RANGE("A3")=NET10        RANGE("B3")=A01     RANGE("C3")=3        RANGE("D3")=3
RANGE("A5")=NET10        RANGE("B5")=A20     RANGE("C5")=5        RANGE("D5")=5
3.2 NET13有4組 A01 1組非A01 故如下   
RANGE("A6")=NET13        RANGE("B6")=A01     RANGE("C6")=6        RANGE("D6")=6
RANGE("A10")=NET13      RANGE("B10")=A20   RANGE("C10")=10   RANGE("D10")=10  
RANGE("A7")=NET13        RANGE("B7")=A01     RANGE("C7")=7        RANGE("D7")=7
RANGE("A10")=NET13      RANGE("B10")=A20   RANGE("C10")=10   RANGE("D10")=10  
RANGE("A8")=NET13        RANGE("B8")=A01     RANGE("C8")=8        RANGE("D8")=8  
RANGE("A10")=NET13      RANGE("B10")=A20   RANGE("C10")=10   RANGE("D10")=10  
RANGE("A9")=NET13        RANGE("B9")=A01     RANGE("C9")=9        RANGE("D9")=9
RANGE("A10")=NET13      RANGE("B10")=A20   RANGE("C10")=10   RANGE("D10")=10  
4.煩不吝賜教  THANKS*10000
作者: 准提部林    時間: 2020-7-11 10:27

Sub TEST()
Dim Arr, Brr, xD, i&, T$, U, a, b, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([Sheet1!d1], [Sheet1!a65536].End(3))
For i = 1 To UBound(Arr)
    T = Arr(i, 1) & IIf(Arr(i, 2) = "A01", "", "|")
    xD(T) = Trim(xD(T) & " " & i)
Next i
ReDim Brr(1 To 30000, 1 To 4)
For Each U In xD.keys
    If xD(U & "|") = "" Then GoTo 101
    For Each a In Split(xD(U), " ")
    For Each b In Split(xD(U & "|"), " ")
        N = N + 2
        For i = 1 To 4
            Brr(N - 1, i) = Arr(a, i)
            Brr(N, i) = Arr(b, i)
        Next
    Next
    Next
101: Next
[Sheet2!A1:D1].Resize(N) = Brr
End Sub


=============================
作者: rouber590324    時間: 2020-7-13 08:55

DEAR 准提部林 大大
完全100%符合需求
小弟非常非常非常感謝 准提部林 大大 解決我工作上之困擾
THANKS *10000
作者: rouber590324    時間: 2020-7-14 08:58

dear  sirs
1.如下將程式copy至需求excel  僅將  sheet1改sheet62    sheet2改sheet106
1.1 停於   Arr = Range([Sheet62!d1], [Sheet62!a65536].End(3))
      出現  "此處須要物件" 無法執行???
2.煩不吝賜教   thanks

Sub TEST()
Dim Arr, Brr, xD, i&, T$, U, a, b, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([Sheet62!d1], [Sheet62!a65536].End(3))
For i = 1 To UBound(Arr)
     T = Arr(i, 1) & IIf(Arr(i, 2) = "A01", "", "|")
     xD(T) = Trim(xD(T) & " " & i)
Next i
ReDim Brr(1 To 30000, 1 To 4)
For Each U In xD.keys
     If xD(U & "|") = "" Then GoTo 101
     For Each a In Split(xD(U), " ")
     For Each b In Split(xD(U & "|"), " ")
         N = N + 2
         For i = 1 To 4
             Brr(N - 1, i) = Arr(a, i)
             Brr(N, i) = Arr(b, i)
         Next
     Next
     Next
101:  Next
[Sheet106!A11].Resize(N) = Brr
End Sub
作者: 准提部林    時間: 2020-7-14 09:57

回復 4# rouber590324


確定有名稱為"Sheet62"的工作表???
作者: rouber590324    時間: 2020-7-14 10:06

DEAR 准提部林 大大
1.懂拉  已改為
Arr = Range(['D-1'!d1], ['D-1'!a65536].End(3))
1.1 程式可運作   thanks*10000



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)