[已解决]再一次求助，编程，急用啊

西北甘霖

要求把工作表中的各个工作薄的A16：A35的数据复制到一个新的工作薄或者工作表当中，一个个复制工作量太大，求各位高手不吝赐教。

最佳答案

月排行榜 / 总排行榜

zjcat35

2012-2-13 21:47

1. Sub tt()
   
2.   Application.ScreenUpdating = False
   
3.   Dim sh As Worksheet, i As Integer
   
4.   With Worksheets("汇总")
   
5.   .Range("a2").Resize(.[a65536].End(3).Row, 1).ClearContents
   
6.     For Each sh In Worksheets
   
7.     i = .Range("a65536").End(3).Row + 1
   
8.       If sh.Name <> "汇总" Then
   
9.         .Cells(i, 1).Resize(20, 1).Value = sh.Range("a16:a35").Value
   
10.       End If
    
11.     Next sh
    
12.     End With
    
13.     Application.ScreenUpdating = True
    
14. End Sub

复制代码

新增一个工作表命名为汇总，见附件

跳转到最佳答案楼层

砂海

楼主偷懒, 把附件中无关内容去掉,
  别人容易看点.

西北甘霖

砂海 发表于 2012-2-13 20:54
楼主偷懒, 把附件中无关内容去掉,
  别人容易看点.

不是啊，应该有将近300个工作薄，如果我一个一个的能删掉，我就可以一个一个的复制出来啊

zjcat35

1. Sub tt()
   
2.   Application.ScreenUpdating = False
   
3.   Dim sh As Worksheet, i As Integer
   
4.   With Worksheets("汇总")
   
5.   .Range("a2").Resize(.[a65536].End(3).Row, 1).ClearContents
   
6.     For Each sh In Worksheets
   
7.     i = .Range("a65536").End(3).Row + 1
   
8.       If sh.Name <> "汇总" Then
   
9.         .Cells(i, 1).Resize(20, 1).Value = sh.Range("a16:a35").Value
   
10.       End If
    
11.     Next sh
    
12.     End With
    
13.     Application.ScreenUpdating = True
    
14. End Sub

复制代码

新增一个工作表命名为汇总，见附件

砂海

附件为示例.学的是方法.

jsgslgd

1. Option Base 1
   
2. Sub jsgslgd()
   
3.     Dim sh  As Worksheet
   
4.     Dim i As Integer, j As Integer, k As Integer
   
5.     Dim arr(), arrtemp()
   
6.     k = 0
   
7.     For Each sh In Worksheets
   
8.         If sh.Name <> "汇总表" Then
   
9.            k = k + 1
   
10.            If k = 1 Then
    
11.               ReDim Preserve arr(1 To 1, 1 To 20)
    
12.               arrtemp = sh.Range("a16:a35").Value
    
13.               For i = 1 To 20
    
14.                 arr(1, i) = arrtemp(i, 1)
    
15.               Next
    
16.            Else
    
17.               j = UBound(arr, 2)
    
18.               ReDim Preserve arr(1 To 1, 1 To j + 20)
    
19.               arrtemp = sh.Range("a16:a35").Value
    
20.               For i = 1 To UBound(arrtemp)
    
21.                   arr(1, j + i) = arrtemp(i, 1)
    
22.               Next
    
23.            End If
    
24.         End If
    
25.     Next
    
26.     Sheets("汇总表").Range("a:a").ClearContents
    
27.     Sheets("汇总表").Range("a1").Resize(UBound(arr, 2)) = Application.Transpose(arr)
    
28. End Sub
    

复制代码

这个是用数组做的，试试看。
SG-104 - 产品质量证明书.rar (576 KB, 下载次数: 9)

2012-2-13 23:39 上传

点击文件名下载附件

ddmyykdzh

学习一下                  

西北甘霖

jsgslgd 发表于 2012-2-13 23:40
这个是用数组做的，试试看。

非常感谢，已使用

linch92413

好壮观啊，楼主，390张表，我也做了一个，练练手，附件太大了，传不上，就贴代码吧
Sub fuzhi_lin()
   Dim N As Integer, i As Integer, j As Integer
   Dim arr
   Dim NSht As Worksheet
   N = Worksheets.Count
   For i = 1 To N
      If Sheets(i).Name = "汇总工作表" Then Exit Sub
   Next i
   ReDim arr(1 To N, 1 To 20)
   Set NSht = Worksheets.Add(before:=Sheets(1))
   NSht.Name = "汇总工作表"
   For i = 1 To N
      For j = 1 To 20
         arr(i, j) = Sheets(i + 1).Cells(15 + j, 1)
      Next j
   Next i
   For i = 2 To N + 1
      NSht.Cells(i - 1, 1) = Sheets(i).Name
   Next i
   NSht.Range("b1").Resize(N, 20) = arr
End Sub