|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
原材料为叫raw data,其中2个Sheet用于取数,一个是movement,一个是fapiaolist 步骤一:我先要从movement 中摘出C列店号相同的部分,只保留A列数据,(part 1数据) 步骤二:然后我要从fapiao list中摘出B列与步骤一相同店号的所有行,保留所有数据,(part2 数据) 步骤三:part1 和 part2数据贴在同一个xls里,中间空一行,单独生成一个店号_年月.xlsx的电子文档,有几个就生成几个,在同一folder里。
我自己试着写了一套,运行的时候总是卡死。
Sub fap()
Dim d, e, arr, brr, crr, k&, i&, j&, sht As Worksheet, x, sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = ActiveSheet
Set d = CreateObject("scripting.dictionary")
Set e = CreateObject("scripting.dictionary")
brr = [a1:f1]
arr = [a1].CurrentRegion
crr = Worksheets("movements").UsedRange
For i = 2 To UBound(arr)
If arr(i, 2) <> "" Then
If Not d.exists(arr(i, 2)) Then Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
d(arr(i, 2))(i) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
End If
Next
For i = 2 To UBound(crr)
If crr(i, 3) <> "" Then
If Not e.exists(crr(i, 3)) Then Set e(crr(i, 3)) = CreateObject("scripting.dictionary")
e(crr(i, 3))(i) = Array(crr(i, 1), crr(i, 2), crr(i, 3))
End If
Next
x = d.keys
For i = 0 To e.Count - 1
Set sht = Worksheets.Add(, ActiveSheet)
[a1] = Worksheets("movements").[a1]
[a2].Resize(e(x(i)).Count, 1) = Application.Transpose(Application.Transpose(e(x(i)).items))
j = e(x(i)).Count + 1
[aj:fj] = brr
k = j + 1
[ak].Resize(d(x(i)).Count, 6) = Application.Transpose(Application.Transpose(d(x(i)).items))
sht.Name = x(i)
Next
sh.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
|
|