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

½Æ»s¥N½X

register313

¦^´_ 4# marklos
¦^´_ 4# GBKEE

·PÁÂ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

½Æ»s¥N½X