- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 254
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-11-23
              
|
7#
發表於 2012-10-3 17:54
| 只看該作者
回復 6# b9208 - Sub ex()
- Set dic = CreateObject("Scripting.Dictionary")
- Set dic1 = CreateObject("Scripting.Dictionary")
- Set dic2 = CreateObject("Scripting.Dictionary")
- With Sheets("List")
- If .[H6].End(xlDown).Row = .Rows.Count Then MsgBox "無資料": Exit Sub '無資料
- For Each a In .Range(.[H6], .[H65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
- ar = Split(a, "+")
- For Each c In ar
- mystr = c & "," & Left(a.Offset(, 3), 8) & "," & a.Offset(, 8)
- dic1(mystr) = Split(mystr, ",")
- Next
- Next
- End With
- With Sheets("明細")
- ay = Application.Transpose(Application.Transpose(dic1.items))
- For i = 1 To UBound(ay, 1)
- mystr = ay(i, 1) & ay(i, 2)
- dic2(ay(i, 1)) = dic2(ay(i, 1)) + 1
- If IsEmpty(dic(mystr)) Then
- ary = Array(ay(i, 1), ay(i, 2), 1)
- Else
- ary = dic(mystr)
- ary(2) = ary(2) + 1
- End If
- dic(mystr) = ary
- Next
- With .[B3].Resize(dic.Count, 3)
- .Value = Application.Transpose(Application.Transpose(dic.items))
- .Sort key1:=.Cells(1, 1), Header:=xlNo
- For Each a In .Columns(1).Cells
- If a <> a.Offset(-1, 0) Then a.Offset(, 3) = dic2(a.Value)
- Next
- End With
- .[I3].Resize(dic2.Count, 1) = Application.Transpose(dic2.keys)
- .[J3].Resize(dic2.Count, 1) = Application.Transpose(dic2.items)
- End With
- End Sub
|
|
發表於 2012-9-30 21:42
| 
