Board logo

標題: [發問] 如何將相同的資料做整列數據的合併及加總 [打印本頁]
作者: marklos    時間: 2012-1-16 21:23     標題: 如何將相同的資料做整列數據的合併及加總

本帖最後由 marklos 於 2012-1-16 21:24 編輯

請問如何將相同的資料作整列數據的合併~詳細需求如下
[attach]9227[/attach]
Sheet1 待處理工作表
將紅色標示內"F"欄位內數量為"0"的, 做整列刪除
將黃色標示內"F"欄位內數量不為"0"者 , 保留
將濾色標示內"A"欄位內資料相同者 , 做合併
[attach]9228[/attach]
Sheet2結果工作表, 需求結果如上圖所示
"F"欄位內數量為"0"的, 整列刪除
原本"A6&A7" 相同資料的欄位 , 其"D"&"G" 兩個欄位資料作合併
, "F" 欄位內的數量部份做加總.
[attach]9229[/attach]
煩請高人指點~
謝謝~
作者: register313    時間: 2012-1-16 22:10

回復 1# marklos

初學者VBA
  1. Sub QQ()
  2. LastRow = [A65535].End(xlUp).Row
  3. For R = LastRow To [A1].Row Step -1
  4.   If Cells(R, "F") = 0 Then
  5.      Rows(R).Delete Shift:=xlUp
  6.   End If
  7.   If R = 1 Then Exit For
  8.   If Cells(R, "A") & Cells(R, "B") & Cells(R, "C") = Cells(R - 1, "A") & Cells(R - 1, "B") & Cells(R - 1, "C") Then
  9.      Cells(R - 1, "D") = Cells(R - 1, "D") & "/" & Cells(R, "D")
  10.      Cells(R - 1, "F") = Cells(R - 1, "F") + Cells(R, "F")
  11.      Cells(R - 1, "G") = Cells(R - 1, "G") & "," & Cells(R, "G")
  12.      Rows(R).Delete Shift:=xlUp
  13.   End If
  14. Next
  15. End Sub
複製代碼
作者: Hsieh    時間: 2012-1-16 22:59

回復 1# marklos
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. With 工作表1
  4. For Each a In .Range(.[A1], .[A1].End(xlDown))
  5. If a.Offset(, 6) <> 0 Then
  6.   If IsEmpty(d(a.Value)) Then
  7.      d(a.Value) = Application.Transpose(Application.Transpose(a.Resize(, 9).Value))
  8.      Else
  9.      ar = d(a.Value)
  10.      ar(4) = ar(4) & "/" & a.Offset(, 3).Value
  11.      ar(6) = ar(6) + a.Offset(, 5).Value
  12.      ar(7) = ar(7) & "," & a.Offset(, 6).Value
  13.      d(a.Value) = ar
  14.    End If
  15. End If
  16. Next
  17. End With
  18. With 工作表2
  19. .Cells = ""
  20. .[A1].Resize(d.Count, 9) = Application.Transpose(Application.Transpose(d.items))
  21. End With
  22. End Sub
複製代碼
作者: marklos    時間: 2012-1-17 11:07

回復 2# register313


    感謝您的幫忙~~
但是還有一事未明
其中"G"欄位資料作合併之後 , 是否可以再加以排序?

感恩~
作者: register313    時間: 2012-1-17 15:58

回復 4# marklos
回復 4# GBKEE

感謝GBKEE完成修改
  1. Sub QQ()
  2. LastRow = [A65535].End(xlUp).Row
  3. For RR = LastRow To [A1].Row Step -1
  4.   If Cells(RR, "F") = 0 Then
  5.      Rows(RR).Delete Shift:=xlUp
  6.   End If
  7.   If RR = 1 Then Exit For
  8.   If Cells(RR, "A") & Cells(RR, "B") & Cells(RR, "C") = Cells(RR - 1, "A") & Cells(RR - 1, "B") & Cells(RR - 1, "C") Then
  9.      Cells(RR - 1, "D") = Cells(RR - 1, "D") & "/" & Cells(RR, "D")
  10.      Cells(RR - 1, "F") = Cells(RR - 1, "F") + Cells(RR, "F")
  11.      Cells(RR - 1, "G") = Cells(RR - 1, "G") & "," & Cells(RR, "G")
  12.      Rows(RR).Delete Shift:=xlUp
  13.   End If
  14. Next
  15. Dim Rng As Range, Ar, xL As Integer, xW As String, R As Range
  16. Set Rng = Sheets("Sheet1").[G1]
  17. Do
  18.     xW = ""
  19.     If InStr(Rng, ",") Then
  20.         For xL = 1 To Len(Rng)
  21.             If Mid(Rng, xL, 1) Like "[A-z]" Then xW = xW & Mid(Rng, xL, 1) Else Exit For
  22.         Next
  23.         Ar = Split(Rng, ",")
  24.         With [IV1].Resize(UBound(Ar) + 1)
  25.             .Value = Application.Transpose(Ar)
  26.             .Cells.Replace xW, ""
  27.             .Sort Key1:=Range("IV1"), Order1:=xlAscending, Header:=xlNo
  28.             For Each R In .Cells
  29.                 R = xW & R
  30.             Next
  31.             Rng = Join(Application.Transpose(.Value), ",")
  32.             .Value = ""
  33.         End With
  34.     End If
  35.     Set Rng = Rng.Offset(1)
  36. Loop Until Rng(1) = ""
  37. End Sub
複製代碼
作者: marklos    時間: 2012-1-18 13:48

回復 5# register313


    感謝您的大力幫忙~~問題已經解決了!!!:P



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