- 帖子
- 967
- 主題
- 0
- 精華
- 0
- 積分
- 1001
- 點名
- 0
- 作業系統
- WIN XP
- 軟體版本
- OFFICE 2003
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-11-29
- 最後登錄
- 2022-5-17
 
|
5#
發表於 2012-1-17 15:58
| 只看該作者
回復 4# marklos
回復 4# GBKEE
感謝GBKEE完成修改- Sub QQ()
- LastRow = [A65535].End(xlUp).Row
- For RR = LastRow To [A1].Row Step -1
- If Cells(RR, "F") = 0 Then
- Rows(RR).Delete Shift:=xlUp
- End If
- If RR = 1 Then Exit For
- If Cells(RR, "A") & Cells(RR, "B") & Cells(RR, "C") = Cells(RR - 1, "A") & Cells(RR - 1, "B") & Cells(RR - 1, "C") Then
- Cells(RR - 1, "D") = Cells(RR - 1, "D") & "/" & Cells(RR, "D")
- Cells(RR - 1, "F") = Cells(RR - 1, "F") + Cells(RR, "F")
- Cells(RR - 1, "G") = Cells(RR - 1, "G") & "," & Cells(RR, "G")
- Rows(RR).Delete Shift:=xlUp
- End If
- Next
- Dim Rng As Range, Ar, xL As Integer, xW As String, R As Range
- Set Rng = Sheets("Sheet1").[G1]
- Do
- xW = ""
- If InStr(Rng, ",") Then
- For xL = 1 To Len(Rng)
- If Mid(Rng, xL, 1) Like "[A-z]" Then xW = xW & Mid(Rng, xL, 1) Else Exit For
- Next
- Ar = Split(Rng, ",")
- With [IV1].Resize(UBound(Ar) + 1)
- .Value = Application.Transpose(Ar)
- .Cells.Replace xW, ""
- .Sort Key1:=Range("IV1"), Order1:=xlAscending, Header:=xlNo
- For Each R In .Cells
- R = xW & R
- Next
- Rng = Join(Application.Transpose(.Value), ",")
- .Value = ""
- End With
- End If
- Set Rng = Rng.Offset(1)
- Loop Until Rng(1) = ""
- End Sub
複製代碼 |
|