返回列表 上一主題 發帖

[發問] 依條件合併資料

[發問] 依條件合併資料

以 S欄 資料作為判斷,相同資料超過一筆以上就將其對應的 D列 資料結合,如果 S欄 中只有一筆的,就直接填入 D欄 的相關資料。附件內有詳細說明
只寫了一部分,但執行不如預期,不知哪裡錯了,還請教導。
test.rar (23.11 KB)
Jess

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

感謝准大,一定花了很多時間。程式碼很深奧,但是我想要達到的效果其實很單純:
工作表"B area" 要轉到 工作表"INVOICE" 的資料是:
Q欄(件數)-->工作表"INVOICE" E欄
N欄(分類) & ( D欄(P/N 料號) & G欄(出貨數) & PCS,..... )-->工作表"INVOICE" F欄(依照 工作表"B area" S欄相同的資料(已用底色標示)將各欄位資料結合為一串文字,在整串結合好的文字前加上N欄(分類))
V欄(Amount (US$))-->工作表"INVOICE" I欄
V欄(Amount (US$)) / Q欄(件數)-->工作表"INVOICE" H欄

以上資料從 工作表"INVOICE" 已存在的最後一筆資料,也就是27列接續往下填入
之前還有結合字串左右加括號、加逗點的問題,但已解決。現在的主要問題是結合出來的 工作表"INVOICE" F欄 資料不正確,其他資料都正確,不用變動。
未命名-1.png
2019-6-30 13:49
Jess

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

准大,您的程式對我的程度來說實在太深奧了,尤其是處理分類字串那部分,幾乎完全看不懂。
我在論壇裡找到一個範例,與我想要的結果還滿接近的,修改了一下,目前看來可用,但就是只能結合字串(字串最右邊會缺一個右括號),沒辦法轉各欄位的數值,能幫我看看加上轉各欄位的數值嗎?
  1. Sub new1()
  2. Set d = CreateObject("Scripting.Dictionary")

  3. For Each s In Range([S7], [S3000].End(xlUp))
  4.    If d(s.Value) = "" Then '如果K欄資料只有一筆不重複
  5.       d(s.Value) = s.Offset(, -5) & " " & "( " & s.Offset(, -15) & "  " & s.Offset(, -12) & " PCS"
  6.       Else
  7.       d(s.Value) = d(s.Value) & ", " & s.Offset(, -15) & "  " & s.Offset(, -12) & " PCS"
  8.     End If
  9. Next

  10. With Sheets("INVOICE")
  11.     xrow = .[F3000].End(xlUp).Row
  12.     .[B3] = xrow
  13.     .Range("C" & xrow + 1, "K3000").ClearContents
  14.     .Range("F" & xrow).Offset(1, 0).Resize(d.Count, 1) = Application.Transpose(d.items)
  15. End With
  16. Set d=Nothing
  17. End Sub
複製代碼
Jess

TOP

        靜思自在 : 【時間如鑽石】時間對一個有智慧的人而言,就如鑽石般珍貴;但對愚人來說,卻像是一把泥土,一點價值也沒有。
返回列表 上一主題