[已解决]历遍工作表复制数据的问题

Redgirl

附件 历遍工作表提取数据附件.zip (28.11 KB, 下载次数: 24)

2013-12-18 10:13 上传

点击文件名下载附件     03版

谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

Zipall

2013-12-18 10:36

1. Sub test()
   
2.     Sheets(1).Select
   
3.     r = Range("A65536").End(xlUp).Row + 2
   
4.     For i = 2 To Sheets.Count
   
5.         With Sheets(i)
   
6.             n = .Range("A65536").End(xlUp).Row - 2
   
7.             .Rows(n).Resize(3).Copy Cells(r, 1)
   
8.             r = r + 4
   
9.         End With
   
10.     Next
    
11. End Sub

复制代码

跳转到最佳答案楼层

爱疯

Sub Click()
    Dim A, B, n, s
    Dim i, j, k

    n = Sheets.Count
    ReDim A(1 To 4 * (n - 1), 1 To 12)


    For i = 2 To n
        '复制一个表
        B = Sheets(i).Range("A36:L38")
        For j = 1 To UBound(B)
            s = s + 1
            For k = 1 To UBound(B, 2)
                A(s, k) = B(j, k)
            Next k
        Next j

        s = s + 1
    Next

    Sheets(1).Range("A:L").ClearContents
    Sheets(1).Range("A1").Resize(UBound(A), UBound(A, 2)) = A
End Sub
历遍工作表提取数据附件2.rar (47.59 KB, 下载次数: 9)

2013-12-18 10:33 上传

点击文件名下载附件

Zipall

1. Sub test()
   
2.     Sheets(1).Select
   
3.     r = Range("A65536").End(xlUp).Row + 2
   
4.     For i = 2 To Sheets.Count
   
5.         With Sheets(i)
   
6.             n = .Range("A65536").End(xlUp).Row - 2
   
7.             .Rows(n).Resize(3).Copy Cells(r, 1)
   
8.             r = r + 4
   
9.         End With
   
10.     Next
    
11. End Sub

复制代码

Redgirl

谢谢老师们帮助。二楼忘了把后面的数据也复制出来。

baksy

可以用公式处理
A1=IF(MOD(ROW(), 4)=0,"",INDIRECT("Sheet"&TRUNC((ROW())/4)+2&"!"&ADDRESS((36+MOD(ROW(), 4)-1),COLUMN())))
公式右拉、下拉。

ZZCUEEI