[已解决]复制多个sheet中数值到一个sheet中，不合并运算

cbce10

多个工作表，格式一样，请教怎么实现把sheet1到8中的所有值复制到sheet9里面？不需要合并运算，只要把数值一行一行，即sheet9中是1到8中所有行的数值。现在sheet9里面是我复制粘贴进去的。

最佳答案

月排行榜 / 总排行榜

qh8600

2015-6-16 18:06

cbce10 发表于 2015-6-16 17:40
请教该怎么写

1. Sub demo()
   
2.     Dim ar(1 To 100000, 1 To 3), br, x, i, j, n
   
3.     n = 1
   
4.     ar(n, 1) = "购销合同类别": ar(n, 2) = "营销类别": ar(n, 3) = "折扣"
   
5.     For x = 1 To Sheets.Count
   
6.         If Sheets(x).Name <> "合并" Then
   
7.             br = Sheets(x).Range("a2:c" & Sheets(x).Cells(Rows.Count, 1).End(3).Row)
   
8.             For i = 1 To UBound(br)
   
9.                 n = n + 1
   
10.                 For j = 1 To 3
    
11.                     ar(n, j) = br(i, j)
    
12.                 Next
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     Range("a1").Resize(n, 3) = ar
    
17. End Sub
    

复制代码

楼主试试
表1.rar (95.74 KB, 下载次数: 7)

2015-6-16 18:07 上传

点击文件名下载附件

跳转到最佳答案楼层

zyouong

这个要用ＶＢＡ代码

cbce10

zyouong 发表于 2015-6-16 17:36
这个要用ＶＢＡ代码

请教该怎么写

qh8600

cbce10 发表于 2015-6-16 17:40
请教该怎么写

1. Sub demo()
   
2.     Dim ar(1 To 100000, 1 To 3), br, x, i, j, n
   
3.     n = 1
   
4.     ar(n, 1) = "购销合同类别": ar(n, 2) = "营销类别": ar(n, 3) = "折扣"
   
5.     For x = 1 To Sheets.Count
   
6.         If Sheets(x).Name <> "合并" Then
   
7.             br = Sheets(x).Range("a2:c" & Sheets(x).Cells(Rows.Count, 1).End(3).Row)
   
8.             For i = 1 To UBound(br)
   
9.                 n = n + 1
   
10.                 For j = 1 To 3
    
11.                     ar(n, j) = br(i, j)
    
12.                 Next
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     Range("a1").Resize(n, 3) = ar
    
17. End Sub
    

复制代码

楼主试试
表1.rar (95.74 KB, 下载次数: 7)

2015-6-16 18:07 上传

点击文件名下载附件

下雨dê天

Sub 合并当前工作簿下的所有工作表()
   
   ''''''''''全表格取消数据筛选
Dim ws As Worksheet
On Error Resume Next
For Each ws In Worksheets
ws.ShowAllData
Next

''''''''''全表格取消数据筛选

Application.ScreenUpdating = False
Sheets("合并当前工作簿").Select
Range("A2:J80000").ClearContents

For j = 1 To Sheets.Count
  If Sheets(j).Name <> ActiveSheet.Name Then
   X = Range("A65536").End(xlUp).Row + 1
   Sheets(j).[2:9000].Copy Cells(X, 1)
End If
Next



Application.ScreenUpdating = True
MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"

End Sub

冥王

……

cbce10

qh8600 发表于 2015-6-16 18:06
楼主试试

谢谢！已经实现。

cbce10

下雨dê天 发表于 2015-6-16 18:11
Sub 合并当前工作簿下的所有工作表()
   
   ''''''''''全表格取消数据筛选

谢谢！自己试了一下，可以实现！

下雨dê天

cbce10 发表于 2015-6-17 09:06
谢谢！自己试了一下，可以实现！