|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Option Explicit
- Sub 多表提取()
- Dim arr1, Dic, arr2(1 To 10000, 1 To 13), Dic1, a, x, k, 位置, kk
- Set Dic = CreateObject("Scripting.Dictionary")
- Set Dic1 = CreateObject("Scripting.Dictionary")
- For a = 1 To Sheets.Count - 1
- arr1 = Sheets(a).Range("A1").CurrentRegion
- For x = 2 To UBound(arr1)
- If Not Dic1.exists(arr1(x, 2)) Then
- kk = kk + 1
- Dic1(arr1(x, 2)) = kk
- arr2(kk, 1) = arr1(x, 2)
- End If
- If Not Dic.exists(arr1(x, 2)) Then
- Dic(arr1(x, 2)) = ""
- 位置 = Application.Match("应发合计", Sheets(a).Range("A1").EntireRow, 0)
- arr2(Dic1(arr1(x, 2)), a + 1) = arr1(x, 位置)
- Else
- arr2(Dic1(arr1(x, 2)), a + 1) = arr2(Dic1(arr1(x, 2)), a + 1) + arr1(x, 位置)
- End If
- Next x
- Dic.RemoveAll
- Next a
- Sheets("汇总").Range("A2:M10000").Clear
- Sheets("汇总").[A2].Resize(kk, 13) = arr2
- End Sub
- Sub 清空()
- Sheets("汇总").Range("A2:M10000").Clear
- End Sub
复制代码
|
|