- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 267
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2025-10-31
               
|
2#
發表於 2012-10-6 16:36
| 只看該作者
本帖最後由 Hsieh 於 2012-10-6 17:25 編輯
回復 1# jessicamsu
試試看- Sub ex()
- Application.DisplayAlerts = False
- Application.ScreenUpdating = False
- Dim Target As Workbook, Sale As Workbook, A As Range, m
- Set dn = CreateObject("Scripting.Dictionary")
- Set dm = CreateObject("Scripting.Dictionary")
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- Set Dic2 = CreateObject("Scripting.Dictionary")
- 10
- m = InputBox("輸入月份", , 8)
- If Val(m) < 1 Or Val(m) > 12 Then GoTo 10
- Set Sale = Workbooks.Open(ThisWorkbook.Path & "\銷售資料.xlsx")
- Set Target = Workbooks.Open(ThisWorkbook.Path & "\目標資料.xlsx")
- With Sale '銷售
- With .Sheets(1)
- For Each A In .Range(.[B2], .[B2].End(xlDown)).SpecialCells(xlCellTypeConstants)
- dm(A.Offset(, 3).Value) = ""
- mystr = A.Value & "," & A.Offset(, -1).Value
- If A.Offset(, 3) = Val(m) Then
- If d(mystr) = "" Then
- d(mystr) = A.Offset(, 1)
- Else
- d(mystr) = IIf(InStr(d(mystr), A.Offset(, 1)) = 0, d(mystr) & "," & A.Offset(, 1), d(mystr))
- End If
- d1(mystr) = d1(mystr) + A.Offset(, 2)
- End If
- dn(mystr) = Array(A.Offset(, -1).Value, A.Value, UBound(Split(d(mystr), ",")) + 1, d1(mystr))
- Next
- End With
- .Close 0
- End With
- With Target '目標
- With .Sheets(1)
- For Each A In .Range(.[B2], .[B2].End(xlDown)).SpecialCells(xlCellTypeConstants)
- dm(A.Offset(, 3).Value) = ""
- mystr = A.Value & "," & A.Offset(, -1).Value
- dn(mystr) = Array(A.Offset(, -1).Value, A.Value, UBound(Split(d(mystr), ",")) + 1, d1(mystr))
- Dic2(A.Offset(, -1) & A & "," & A.Offset(, 3)) = A.Offset(, 2)
- Next
- End With
- .Close 0
- End With
- With ActiveSheet
- .UsedRange.EntireColumn.Delete
- .[A1:A2] = "Sales Name": .[B1:B2] = "Bill TO": .[C1:C2] = "客戶數" & Chr(10) & "(" & m & "月)": .[D2] = "銷售量" & Chr(10) & "(" & m & "月)"
- .[D1:E1] = "銷售實績": .[F1].Resize(, dm.Count - 1) = "目標"
- With .[A3].Resize(dn.Count, 4)
- .Value = Application.Transpose(Application.Transpose(dn.items))
- .Sort key1:=.Cells(1, 2), key2:=.Cells(1, 1), Header:=xlNo
- k = 4
- For Each ky In dm.keys
- ActiveSheet.Cells(2, k + 1) = "(" & ky & "月份)"
- For Each A In .Columns(1).Cells
- mystr = A & A.Offset(, 1) & "," & ky
- A.Offset(, k) = Dic2(mystr)
- Next
- k = k + 1
- Next
- End With
- With .Range("A2").CurrentRegion.Offset(1)
- .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
- 7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
- .Cells(1, 1).ClearOutline
- For r = .Rows.Count To 3 Step -1
- Set A = .Cells(r, 2)
- If A = A.Offset(-1, 0) Then Range(A, A.Offset(-1, 0)).Merge
- Next
- End With
- .[A1:A2].Merge
- .[B1:B2].Merge
- .[C1:C2].Merge
- .[D1:E1].Merge
- .[F1].Resize(, dm.Count - 1).Merge
- .UsedRange.SpecialCells(xlCellTypeFormulas).Font.Bold = True
- End With
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
|
|
發表於 2012-10-5 22:25
| 
