楼主
kevinchengcw |
Q: 如何利用vba代码根据相同样式表格的数据采集点坐标整理数据？
A: 代码如下：
- Sub test()
- Dim Rng As Range, RngS As Range, Rules, ArrS, Arr, N&, I&, T&
- Rules = Array(1, 3, 3, 1, 3, 2, 3, 3, 3, 4, 3, 5, 3, 6, 3, 7, 7, 8, 7, 9, 7, 10, 4, 1, 4, 2, 4, 3, 4, 4, 4, 5, 4, 6, 4, 7, 13, 1, 13, 2, 13, 3, 13, 5, 14, 1, 14, 2, 14, 3, 14, 5, 15, 1, 15, 2, 15, 3, 15, 5) '设定数据采集点坐标,为相对表格标题单元格位置的偏移量,两个一组,分别为行和列的偏移值
- T = Int((UBound(Rules) + 1) / 2) '取得坐标数组项目数的半数值,即坐标点个数
- ReDim Arr(1 To T, 1 To 1) '定义结果数组与坐标点个数相等
- ArrS = Worksheets("数据库").UsedRange.Value '将数据源的使用区域的数据赋值给数组
- For N = LBound(ArrS) To UBound(ArrS) '循环数据源各行
- If Trim(ArrS(N, 1)) = "已婚育龄妇女卡" Then '如果当前行A列值与表格标题行一致,则
- If Arr(2, UBound(Arr, 2)) <> "" Then ReDim Preserve Arr(1 To T, 1 To UBound(Arr, 2) + 1) '判断结果数组是否已满,如果已满,则增加一列
- For I = LBound(Arr) To UBound(Arr) '循环结果数组各行,将对应位置的数据依坐标点位置提取出后放入
- Arr(I, UBound(Arr, 2)) = ArrS(N + Rules((I - 1) * 2), 1 + Rules((I - 1) * 2 + 1))
- Next I
- End If
- Next N
- With Worksheets("二维表格")
- .Rows("2:" & .Rows.Count).ClearContents '清空数据区内容
- .[a2].Resize(UBound(Arr, 2), UBound(Arr)) = Application.Transpose(Arr) '将结果数组转置到数据区中(因行列互换原因)
- End With
- End Sub
详见附件及素材源帖.
 把有大量合并的单元格变为二维表格并提到一些数据.rar
|