返回列表 上一主題 發帖

[發問] 依條件合併資料

Sub test()
Dim Arr, Brr, xD, R&, i&, N&, T$, TY$, TR
Sheets("INVOICE").UsedRange.Offset(7, 0).EntireRow.Delete
Set xD = CreateObject("scripting.dictionary")
R = Sheets("B area").[G5000].End(xlUp).Row
Arr = Sheets("B area").Range("A7:X" & R)
ReDim Brr(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    T = Arr(i, 19):   R = xD(T):   If T = "" Then GoTo 101
    TY = Arr(i, 14) & "*" & Format(Arr(i, 7), "#,##0") & "pcs"  '料號*出貨數 文字串, 可將*改為空格
    If R = 0 Then
       N = N + 1: xD(T) = N: R = N
       Brr(N, 1) = N '序號
       Brr(N, 2) = "PKG"
       Brr(N, 3) = Arr(i, 17) '件數
       Brr(N, 6) = Arr(i, 22) / Arr(i, 17) 'Unit Price (US$)
       Brr(N, 7) = Arr(i, 22) 'Amount (US$)
    End If
    Brr(R, 5) = Val(Brr(R, 5)) + Val(Arr(i, 7)) '出貨數(累計)
    Brr(R, 8) = Val(Brr(R, 8)) + Val(Arr(i, 8)) '淨重(累計)
    Brr(R, 9) = Val(Brr(R, 9)) + Val(Arr(i, 9)) '毛重(累計)
    '------------------------------------
    T = Replace(Replace(Brr(R, 4), "//", "("), ")", "") '取得原分類文字
    If T = "" Then Brr(R, 4) = Arr(i, 14) & "//" & TY: GoTo 101
    TR = Split(T, "(")  '拆解原分類文字
    Brr(R, 4) = Trim(TR(0)) & " ( " & Trim(TR(1)) & ", " & TY & " )" '分類(加註)
101: Next i
If N = 0 Then Exit Sub
With Sheets("INVOICE").[C8].Resize(N, 9)
     .Value = Brr
     .Columns(4).Replace "//*", "", Lookat:=xlPart '若為單筆, 清除後面的加註文字
     .Columns(4).WrapText = True '自動換列
     .Columns(4).EntireRow.AutoFit '自動列高
     .Borders.LineStyle = 1  '框線
     Application.Goto .Item(1) '跳至INVOICE工作表
End With
End Sub

test_v1.rar (29.79 KB)


============================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 3# jesscc

Sub test()
Dim Arr, Brr, xD, R&, i&, N&, T$, TY$, TR, xE As Range
Set xD = CreateObject("scripting.dictionary")
R = Sheets("B area").[G5000].End(xlUp).Row
Arr = Sheets("B area").Range("A7:X" & R)
ReDim Brr(1 To R, 1 To 9)
For i = 1 To UBound(Arr)
    T = Arr(i, 19):   R = xD(T):   If T = "" Then GoTo 101
    TY = Arr(i, 14) & "*" & Format(Arr(i, 7), "#,##0") & "pcs"  '料號*出貨數 文字串, 可將*改為空格
    If R = 0 Then
       N = N + 1: xD(T) = N: R = N
       'Brr(N, 1) = N '序號
       Brr(N, 2) = "PKG"
       Brr(N, 3) = Arr(i, 17) '件數
       Brr(N, 6) = Arr(i, 22) / Arr(i, 17) 'Unit Price (US$)
       Brr(N, 7) = Arr(i, 22) 'Amount (US$)
    End If
    'Brr(R, 5) = Val(Brr(R, 5)) + Val(Arr(i, 7)) '出貨數(累計)
    'Brr(R, 8) = Val(Brr(R, 8)) + Val(Arr(i, 8)) '淨重(累計)
    'Brr(R, 9) = Val(Brr(R, 9)) + Val(Arr(i, 9)) '毛重(累計)
    '------------------------------------
    T = Replace(Replace(Brr(R, 4), "//", "("), ")", "") '取得原分類文字
    If T = "" Then Brr(R, 4) = Arr(i, 14) & "//" & TY: GoTo 101
    TR = Split(T, "(")  '拆解原分類文字
    Brr(R, 4) = Trim(TR(0)) & " ( " & Trim(TR(1)) & ", " & TY & " )" '分類(加註)
101: Next i
If N = 0 Then Exit Sub
Set xE = Sheets("INVOICE").[D65536].End(xlUp)(2, 0)
With xE.Resize(N, 9)
     .Value = Brr
     .Columns(4).Replace "//*", "", Lookat:=xlPart '若為單筆, 清除後面的加註文字
     .Columns(4).WrapText = True '自動換列
     .Columns(4).EntireRow.AutoFit '自動列高
     .Borders.LineStyle = 1  '框線
     Application.Goto .Item(1) '跳至INVOICE工作表
End With
End Sub


========================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

        靜思自在 : 【停滯不前,終無所得】人都迷於尋找奇蹟,因而停滯不前;縱使時間再多、路再長,也了無用處,終無所得。
返回列表 上一主題