请老师看看这个提取的代码怎么写?

ryoryo66

表格1中从J列开始,每2列的最后一行的2格数字,把他们复制到从A7开始,
如果为空的话,就让那一行空着.

请问这个提取应该怎么写啊?  (A7:B29就是想要的结果)

爱疯

Sub test()
    Dim A(1 To 100, 1 To 2)     '如果100不够，自己改大
    Dim x, s, i, j, rng
    For i = 1 To 2              '遍历2个大组
        For j = 1 To 11         '遍历（1个大组里包含）11个小组
            s = s + 1           '数组A的计数
            x = 9 + (i - 1) + (i - 1) * 33 + (j - 1) * 3 + 1
            Set rng = Cells(Rows.Count, x)
            Set rng = Columns(x).Find("*", rng, , , , 2)
            If Not rng Is Nothing Then A(s, 1) = rng: A(s, 2) = rng.Offset(0, 1)
        Next j
        s = s + 1
    Next i
    [d:e] = ""                  '自己改成输出到A列
    [d7].Resize(s, 2) = A
End Sub


1.rar (96.83 KB, 下载次数: 3)

2019-10-6 11:54 上传

点击文件名下载附件

ryoryo66

爱疯 发表于 2019-10-6 11:54
Sub test()
    Dim A(1 To 100, 1 To 2)     '如果100不够，自己改大
    Dim x, s, i, j, rng

非常感谢老师,我后来又加了2个大组,每组有15个小组.
麻烦您再帮我看一次!

爱疯

ryoryo66 发表于 2019-10-6 14:49
非常感谢老师,我后来又加了2个大组,每组有15个小组.
麻烦您再帮我看一次!

数据没变化吧，是这个附件吗

ryoryo66

爱疯 发表于 2019-10-6 18:43
数据没变化吧，是这个附件吗

新的附件就是加了2个大组,其它的没有变!

爱疯

如果只增2个大组，就把 For i = 1 To 2，改成 For i = 1 To 4
因为没发现有你说的新增了数据的附件，所以只能这样说下。

ryoryo66

爱疯 发表于 2019-10-6 19:30
如果只增2个大组，就把 For i = 1 To 2，改成 For i = 1 To 4
因为没发现有你说的新增了数据的附件，所以 ...

非常抱歉老师,我上传错误了!

这是附件,加了2个大组.

爱疯

Sub CommandButton1_Click()
    Dim A(1 To 500, 1 To 4), B, rng     '如果500不够，再改大
    Dim x, y, s, i, j
    B = Array(11, 11, 15, 15)           '几个大组，其中各有几个小组

    For i = LBound(B) To UBound(B)      '遍历大组
        For j = 1 To B(i)               '遍历小组
            s = s + 1                   '数组A的计数
            x = (9 + i) + (y * 3) + ((j - 1) * 3 + 1)
            Set rng = Cells(Rows.Count, x)
            Set rng = Columns(x).Find("*", rng, , , , 2)
            If Not rng Is Nothing Then A(s, 1) = rng: A(s, 2) = rng.Offset(0, 1)
        Next j
        y = y + B(i)                    '小组的累计
        s = s + 1
    Next i

    [d:e] = ""
    [d7].Resize(s, 2) = A
End Sub


2.rar (226.48 KB, 下载次数: 6)

2019-10-6 20:32 上传

点击文件名下载附件

ryoryo66

爱疯 发表于 2019-10-6 20:29
Sub CommandButton1_Click()
    Dim A(1 To 500, 1 To 4), B, rng     '如果500不够，再改大
    Dim x, ...

非常感谢老师,辛苦了!