VBA的灵活妙用解决复杂的Excel问题

VBA的灵活妙用解决复杂的Excel问题

有一天老板丢给我一个复杂的Excel问题，内容简化了一下，大概是这样的

十万行数据，要根据部门和人员来把日期填进去，要求是填写销售部门的ABC 和 BBC 两个人的日期，假设这十万行里面有9万的是销售部门，销售部门里面有3.1万的ABC，有3.1万个BBC，那么一共要填写6.2万行，日期的要求是根据十月平均到每天来填写，6.2万行那么平均下来31天，每一个日期就要填写2千行，格式不变。

如果是常规操作，那么首先是筛选，看看一起有多少符合条件的行，再除以31，可以知道每个日期需要复制多少行，然后再一个一个下来复制，这样不仅效率低下，而且容易出错，如果以后再碰见类似的问题，还要再重复操作一遍。

如果用VBA来操作这些，则简单多了，而且以后类似的问题，也只需要改改简单的代码，即可完成复杂的操作。

Sub caozuo()

Dim i, j, personnel1, personnel2, total, nowtotal, nowData '定义变量
Dim arr() '定义数组
Set sht = Sheet2 '把表格赋值给变量

arr = Range("a1:d" & sht.Range("d65536").End(xlUp).Row)   '创建数组
personnel1 = "ABC"    '确定两个销售人员
personnel2 = "BBC"
department = "销售"     '确定部门
 '计算数据表格里面销售部门里面有多少ABC,BBC
total = Application.WorksheetFunction.CountIfs(sht.[b:b], personnel1, sht.[a:a], department) + _
            Application.WorksheetFunction.CountIfs(sht.[b:b], personnel2, sht.[a:a], department)
           
total = Application.WorksheetFunction.RoundUp(total / 31, 0)   '确定每个日期要添加的行数（平均数），向上取整  
nowtotal = total    '将这个值赋值给另外一个变量
j = 0                '构建一个变量在循环中累加
nowData = 43739     '将2019年10月1日变为数值方便计算

For i = LBound(arr) To UBound(arr)       '创建循环
        If arr(i, 1) = department And (arr(i, 2) = personnel1 Or arr(i, 2) = personnel2)_
             And j < total Then         '查找满足条件的行，并且让填写日期
                Range("c" & i) = Application.WorksheetFunction.Text(nowData, "yyyy-mm-dd")
                j = j + 1      '每次填写之后记录下来，直到超过平均数
                If j = total Then      '如果等于平均数了，则让下一个日期在平均数之间填写
                    total = total + nowtotal
                    nowData = nowData + 1        '日期加一天
                End If
        End If
Next

End Sub

逻辑简而言之：用数组循环这十万行，如果某一行是销售部门的ABC或者是BBC，那么，将这行的日期填写为2019-10-1，如果已经填写了2000行了，则下次再找到销售部门的ABC或者是BBC，填写2019-10-2，依次类推执行下次，整个循环过程，十秒钟完成十万行数据的循环和填写。

完成后的效果如图