麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼