[發問] 如何將相同的資料做整列數據的合併及加總

marklos

請問如何將相同的資料作整列數據的合併~詳細需求如下

下載 (87.5 KB)

2012-1-16 21:19

Sheet1 待處理工作表
將紅色標示內"F"欄位內數量為"0"的, 做整列刪除
將黃色標示內"F"欄位內數量不為"0"者 , 保留
將濾色標示內"A"欄位內資料相同者 , 做合併

下載 (57.87 KB)

2012-1-16 21:19

Sheet2結果工作表, 需求結果如上圖所示
"F"欄位內數量為"0"的, 整列刪除
原本"A6&A7" 相同資料的欄位 , 其"D"&"G" 兩個欄位資料作合併
, "F" 欄位內的數量部份做加總.
QQ2.rar (2.21 KB)

下載次數: 30

2012-1-16 21:20

煩請高人指點~
謝謝~

register313

回復 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

回復 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

回復 2# register313


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

感恩~

register313

回復 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

回復 5# register313


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