|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 提取数据()
ReDim brr(1 To 9999, 1 To 1)
Rem 重新定义数组,过程复制数组
Dim ar()
Dim arr()
Dim st
Dim i
Dim r
Dim x
Dim sh As Worksheet
ar = Array(2, 3, 4, 5, 6, 7, 8, 9, 11)
Rem 各工作表需要复制的列位置
For Each sh In Sheets
If Right(sh.Name, 2) = "项目" Then
arr = sh.Range("a1").CurrentRegion
Rem 各需要复制的工作表连续数据区域
st = Replace(Split(Trim(Split(arr(1, 1), ":")(1)))(0), "项目工程概况报备表", "")
st = Split(st, "公司")
Rem 提取分公司和项目名称
For i = 5 To UBound(arr)
If arr(i, 2) = "" Then arr(i, 2) = arr(i - 1, 2)
If arr(i, 3) = "" Then arr(i, 3) = arr(i - 1, 3)
If arr(i, 4) = "" Then arr(i, 4) = arr(i - 1, 4)
Rem 提取分项工程
If arr(i, 6) = "√" Then
r = r + 1
brr(r, 1) = r: brr(r, 2) = st(0) & "公司": brr(r, 3) = st(1)
For x = 0 To UBound(ar)
brr(r, x + 4) = arr(i, ar(x))
Next x
Rem 提取方案信息
End If
Next i
End If
Next
With Sheets("收集页面")
.UsedRange.Offset(2) = ""
Rem 清空复制区域
.Range("a3").Resize(r, UBound(brr, 2)) = brr
End With
End Sub
|
|