Board logo

標題: [發問] 依條件合併資料 [打印本頁]
作者: jesscc    時間: 2019-6-29 11:05     標題: 依條件合併資料

以 S欄 資料作為判斷，相同資料超過一筆以上就將其對應的 D列 資料結合，如果 S欄 中只有一筆的，就直接填入 D欄 的相關資料。附件內有詳細說明
只寫了一部分，但執行不如預期，不知哪裡錯了，還請教導。
[attach]30960[/attach]
作者: 准提部林    時間: 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

[attach]30965[/attach]


============================
作者: jesscc    時間: 2019-6-30 13:51

感謝准大，一定花了很多時間。程式碼很深奧，但是我想要達到的效果其實很單純:
工作表"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欄 資料不正確，其他資料都正確，不用變動。
[attach]30966[/attach]
作者: 准提部林    時間: 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


========================
作者: jesscc    時間: 2019-6-30 18:39

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

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

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




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