返回列表 上一主題 發帖

[發問] 依條件合併資料

准提部林

帖子
2798 
主題
10 
精華
0 
積分
2854 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-4-20 
1# 跳轉到 »
發表於 2019-6-30 11:22 | 顯示全部帖子
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)


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

TOP

准提部林

帖子
2798 
主題
10 
精華
0 
積分
2854 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-4-20 
2#
發表於 2019-6-30 14:36 | 顯示全部帖子
回復 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


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

TOP

        靜思自在 : 我們要做好社會的環保，也要做好內心的環保。
返回列表 上一主題