快速浏览
实用案例
|日期控件||简单的收发存||收费管理系(Access改进版)|
|中医诊所收费系统(Excel版)||中医诊所收费系统(Access版)||银行对账单自动勾对|
收费使用项目
|财务管理系统||工资薪金和年终奖个税筹划||新税法下工资表模版|
内容提要
客户销售额查询分析（更新）|完整代码
1、在工作表“统计查看”里，工作表Selection Change事件，设置单元格数据验证；命令按钮点击事件，提取数据并写入工作表；自定义函数getData，根据年度从字典中提取数据到数组temp：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim arr()If Target.Address = "$G$2" ThenCall checkDicarr = dicYear.keysCall SetDataValidation(arr, Target)End IfEnd SubPrivate Sub CmdSum_Click()Dim i As Integer, j As IntegerDim rng As RangeDim currYear As StringDim temp, iRow As Integer, iCol As IntegerDim dkey, sortType As String, sortKey As Range, strOrder As String, orderType As IntegerCall checkDiccurrYear = Range("G2").ValuesortType = Range("J2").ValuestrOrder = Range("L2").ValueiRow = UsedRange.Rows.CountIf iRow > 3 ThenCells(4, 1).Resize(iRow, UsedRange.Columns.Count).ClearEnd Iftemp = getData(currYear)iRow = UBound(temp)iCol = UBound(temp, 2)Set rng = Cells(3, 1).Resize(iRow, iCol)With rng.Value = temp.Borders.LineStyle = 1.Offset(1, 1).NumberFormat = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ ".Columns(iCol).Offset(1).NumberFormat = "_ * #,##0.00_ 元;_ * -#,##0.00_ 元;_ * ""-""??_ 元;_ @_ 元".Columns.AutoFit'//排序If sortType = "客户" Or sortType = "合计" ThenIf sortType = "客户" ThenSet sortKey = .Columns(1)ElseSet sortKey = .Columns(.Columns.Count)End IfIf strOrder = "降序" ThenorderType = 2ElseorderType = 1End If.Resize(.Rows.Count - 1, .Columns.Count).Sort key1:=sortKey, Order1:=orderType, _Header:=xlYes, OrderCustom:=1, MatchCase:=False, _Orientation:=xlTopToBottomEnd IfEnd WithEnd SubPrivate Function getData(currYear As String) As VariantDim i As Integer, j As IntegerDim temp(), iRow As Integer, iCol As IntegerDim dkeyCall checkDiciRow = dic.Count + 2iCol = 14ReDim temp(1 To iRow, 1 To iCol)For i = 1 To 12temp(1, i + 1) = monthText(i, 1)Nexttemp(1, 1) = "客户名称"temp(1, iCol) = "合计"temp(iRow, 1) = "合计"i = 1For Each dkey In dic.keysi = i + 1temp(i, 1) = dkeyIf dic(dkey).exists(currYear) ThenFor j = 1 To 12temp(i, j + 1) = dic(dkey)(currYear)(j)temp(iRow, j + 1) = temp(iRow, j + 1) + temp(i, j + 1)temp(i, iCol) = temp(i, iCol) + temp(i, j + 1)temp(iRow, iCol) = temp(iRow, iCol) + temp(i, j + 1)NextEnd IfNextgetData = tempEnd Function
2、在工作表“客户单月数据”里，命令按钮点击事件；工作表Change事件，工作表Selection Change事件；ComboBox的Change事件，下拉箭头点击事件，addCombList自定义过程，添加List；getData自定义过程：
Private Sub CmdGetData_Click()Call getDicCall getDataEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)Dim arr(), key As VariantDim i As LongDim customer As String, currYear As String, preYear As StringDim currMonth As IntegerDebug.Print Target.AddressIf Target.Address = "$C$3" Or Target.Address = "$C$4" Or Target.Address = "$F$4" ThenCall getDataEnd IfEnd SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)Dim arr()If Target.Address = "$C$3:$E$3" Or Target.Address = "$C$4" Or Target.Address = "$F$4" ThenCall checkDicEnd IfIf Target.Address = "$C$4" Or Target.Address = "$F$4" ThenCall checkDicarr = dicYear.keysCall SetDataValidation(arr, Target)End IfEnd SubPrivate Sub ComboBox1_Change()Call addCombListRange("C3").Value = Me.ComboBox1.TextEnd SubPrivate Sub addCombList()Dim currValue As StringDim arr(), temp(), sList As ObjectDim listCount As IntegerSet sList = CreateObject("System.Collections.SortedList")currValue = Me.ComboBox1.TextCall checkDicarr = dic.keysFor i = 0 To UBound(arr)If InStr(arr(i), currValue) > 0 ThensList(arr(i)) = ""listCount = listCount + 1End IfNextIf listCount > 0 ThenReDim temp(listCount - 1)For i = 0 To listCount - 1temp(i) = sList.getkey(i)NextMe.ComboBox1.List = tempElseSet sList = CreateObject("System.Collections.SortedList")For i = 0 To UBound(arr)sList(arr(i)) = ""NextFor i = 0 To UBound(arr)arr(i) = sList.getkey(i)NextMe.ComboBox1.List = arrEnd IfEnd SubPrivate Sub ComboBox1_DropButtonClick()With Me.ComboBox1If .listCount = 0 ThenCall checkDicEnd IfEnd WithCall addCombListEnd SubPrivate Sub getData()Dim arr(), key As VariantDim i As LongDim customer As String, currYear As String, preYear As StringDim currMonth As Integercustomer = Range("C3").ValuecurrYear = Range("C4")preYear = Range("F4")Range("C6").Resize(12, 1) = 0Range("F6").Resize(12, 1) = 0Call checkDicIf dic.exists(customer) Then'//左边年度If dic(customer).exists(currYear) Theni = 0ReDim arr(1 To 12, 1 To 2)For Each key In dic(customer)(currYear).keyscurrMonth = keyi = i + 1arr(i, 1) = monthText(currMonth, 2)arr(i, 2) = dic(customer)(currYear)(key)NextRange("B6").Resize(12, 2) = arrEnd If'//右边年度If dic(customer).exists(preYear) Theni = 0ReDim arr(1 To 12, 1 To 2)For Each key In dic(customer)(preYear).keyscurrMonth = keyi = i + 1arr(i, 1) = monthText(currMonth, 2)arr(i, 2) = dic(customer)(preYear)(key)NextRange("E6").Resize(12, 2) = arrEnd IfEnd IfEnd Sub
Option ExplicitPublic dic As ObjectPublic dicYear As ObjectSub getDic()Dim i As Long, j As LongDim key1, key2, key3Dim ws As WorksheetDim arr(), customer, currYear As String, currMonth As IntegerDim sales As DoubleSet dic = CreateObject("Scripting.Dictionary")Set dicYear = CreateObject("Scripting.Dictionary")For Each ws In ThisWorkbook.SheetsWith wsIf InStr(.Range("A1"), "年销售数据") > 0 Thenarr = .Range("A1").CurrentRegionFor i = 3 To UBound(arr)customer = arr(i, 1)currYear = Year(arr(i, 2)) & "年"currMonth = Month(arr(i, 2))sales = arr(i, 8)dicYear(currYear) = ""If Not dic.exists(customer) ThenSet dic(customer) = CreateObject("Scripting.Dictionary")End IfIf Not dic(customer).exists(currYear) ThenSet dic(customer)(currYear) = CreateObject("Scripting.Dictionary")For j = 1 To 12dic(customer)(currYear)(j) = 0NextEnd Ifdic(customer)(currYear)(currMonth) = dic(customer)(currYear)(currMonth) + salesNextEnd IfEnd WithNextEnd SubSub checkDic()If dic Is Nothing Or dicYear Is Nothing ThenCall getDicElseIf dic.Count = 0 Or dicYear.Count = 0 ThenCall getDicEnd IfEnd SubFunction monthText(currMonth As Integer, Optional mType As Integer = 0)If mType = 0 ThenSelect Case currMonthCase Is = 1monthText = "一月"Case Is = 2monthText = "二月"Case Is = 3monthText = "三月"Case Is = 4monthText = "四月"Case Is = 5monthText = "五月"Case Is = 6monthText = "六月"Case Is = 7monthText = "七月"Case Is = 8monthText = "八月"Case Is = 9monthText = "九月"Case Is = 10monthText = "十月"Case Is = 11monthText = "十一月"Case Is = 12monthText = "十二月"Case ElsemonthText = "无效月份"End SelectElseIf mType = 1 ThenSelect Case currMonthCase Is = 1monthText = "一月份"Case Is = 2monthText = "二月份"Case Is = 3monthText = "三月份"Case Is = 4monthText = "四月份"Case Is = 5monthText = "五月份"Case Is = 6monthText = "六月份"Case Is = 7monthText = "七月份"Case Is = 8monthText = "八月份"Case Is = 9monthText = "九月份"Case Is = 10monthText = "十月份"Case Is = 11monthText = "十一月份"Case Is = 12monthText = "十二月份"Case ElsemonthText = "无效月份"End SelectElseIf mType = 2 ThenmonthText = currMonth & "月份"End IfEnd FunctionSub SetDataValidation(arr(), rng As Range)'//设置单元格数据验证Dim i As Integer, t As IntegerDim listStr As StringDim rngValue As StringrngValue = rng.ValueFor i = LBound(arr) To UBound(arr)listStr = listStr & arr(i) & ","If rngValue = CStr(arr(i)) Thent = 1End IfNextIf t = 0 Then rng = ""'//去掉结尾的 ","listStr = Left(listStr, Len(listStr) - 1)With rng.Validation'//删除已有的数据验证.Delete'//添加数据验证，源为listStr.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=listStr.IgnoreBlank = True.InCellDropdown = True.ShowInput = True.ShowError = False '//不显示出错警告，改为TRUE则显示，同时不能输入不合验证的字符End WithEnd Sub
| 安利小店 安利的牙膏非常不错，用了以后就不想再用其他的了；洗洁精、洗衣液也是日常必备，用过都说好！ | |
| 合谷医疗 合谷医疗专攻各种疑难杂症，尤其擅长腰颈椎疾病、儿童神经发育异常、多动症、自闭孤独症治疗，可谓神乎其技！体验过的直呼早点来就好了！ | |
| 我的付费知识星球：Excel活学活用 帮助VBA初学者提高VBA编程水平，欢迎加入！ |
喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！
Excel问题，请在文章下面留言讨论！或者加入我的付费交流群提问！
如需案例文件，请按当天另一篇文章末尾案例文件分享说明操作！
