如何写loop合併到工作表上

sisusum

老师们，我已经写了从第2个Sheet第5个Sheet各自的储存格A3到G3汇集到Sheet"Chart"内，但要怎样写才能自动loop把第2个Sheet第5个Sheet各自的储存格A4到G4也汇集到Sheet"Chart"，然后是储存格A5到G5一直重複下去呢？

Sub 宏6()

    '1

    Sheets("二分之一层").Select

    '2

    Range("A3").Select

    '3

    Range(Selection, Selection.End(xlToRight)).Select

    '4

    Selection.Copy

    '5

    Sheets("Chart").Select

    '6

    Range("C3").Select

    '7

    ActiveSheet.Paste

    '8

    ActiveCell.Offset(1, 0).Select

    '9

    Sheets("四分之一层").Select

    '10

    Range("A3").Select

    '11

    Range(Selection, Selection.End(xlToRight)).Select

    '12

    Selection.Copy

    '13

    Sheets("Chart").Select

    '14

    ActiveSheet.Paste

    '15

    ActiveCell.Offset(1, 0).Select

    '16

    Sheets("八分之一层").Select

    '17

    Range("A3").Select

    '18

    Range(Selection, Selection.End(xlToRight)).Select

    '19

    Selection.Copy

    '20

    Sheets("Chart").Select

    '21

    ActiveSheet.Paste

    '22

    ActiveCell.Offset(1, 0).Select

    '23

    Sheets("88层").Select

    '24

    Range("A3").Select

    '25

    Range(Selection, Selection.End(xlToRight)).Select

    '26

    Selection.Copy

    '27

    Sheets("Chart").Select

    '28

    ActiveSheet.Paste

    '29

    ActiveCell.Offset(1, 0).Select

End Sub

Henry D. Sy

是不是这个意思?
一条记录就得转换工作表吗???

1. Private Sub MergeTbl_Click()
   
2.     Dim arr(1 To 4) As String
   
3.     Dim tempArr()
   
4.     Dim i As Integer
   
5.     Dim j As Integer
   
6.     Dim k As Integer
   
7.     Dim m As Integer
   
8.     Dim intRows As Long
   
9.     Dim strSheetName As String
   
10.     j = 1
    
11.     m = 1
    
12.     For i = 1 To ActiveWorkbook.Sheets.Count
    
13.         strSheetName = ActiveWorkbook.Sheets(i).Name
    
14.         Select Case Left(strSheetName, 1)
    
15.         Case "二", "四", "八", "8"
    
16.             arr(j) = strSheetName
    
17.             j = j + 1
    
18.         End Select
    
19.     Next
    
20.     intRows = (Worksheets(arr(1)).Range("A65535").End(xlUp).Row - 2) * UBound(arr)
    
21.     ReDim tempArr(1 To intRows, 1 To 8)
    
22.     For i = 1 To intRows
    
23.         k = i Mod UBound(arr)
    
24.         If k = 0 Then
    
25.             k = UBound(arr)
    
26.         End If
    
27.         tempArr(i, 1) = arr(k)
    
28.         For j = 2 To 8
    
29.             tempArr(i, j) = Worksheets(arr(k)).Cells(m + 2, j - 1)
    
30.         Next
    
31.         If i Mod UBound(arr) = 0 Then
    
32.             m = m + 1
    
33.         End If
    
34.     Next
    
35.     Application.ScreenUpdating = False
    
36.     Range(Cells(2, 1), Cells(intRows + 1, 8)).ClearContents
    
37.     Range(Cells(2, 1), Cells(intRows + 1, 8)) = tempArr
    
38.     Application.ScreenUpdating = True
    
39. End Sub
    

复制代码

sisusum

首先谢谢你的代码，我要先下载用回看一下是不是这样子。

可能我讲得不够清楚，其实有4个工作表，分别叫(1/2层，1/4层，1/8层，88层)﹐上面的数据，我自己会手动添加进去。

我只要想要把这4个工作表上的数据合併到最后叫Chart的工作表上去。

Sheet"1/2层"的A3到G3汇集到Sheet"Chart"的C3到I3
Sheet"1/4层"的A3到G3汇集到Sheet"Chart"的C4到I4
Sheet"1/8层"的A3到G3汇集到Sheet"Chart"的C5到I5
Sheet"88层"的A3到G3汇集到Sheet"Chart"的C6到I6


然后再重覆的是
Sheet"1/2层"的A4到G4汇集到Sheet"Chart"的C7到I7
Sheet"1/4层"的A4到G4汇集到Sheet"Chart"的C8到I8
Sheet"1/8层"的A4到G4汇集到Sheet"Chart"的C9到I9
Sheet"88层"的A4到G4汇集到Sheet"Chart"的C10到I10

一直汇集下去，把前面的4个工作表的数据合併到Chart的工作表去。

我之前做的代码只是写了以下这个部份，但发现跑完了就不知道再怎样让其他的也自动跑下去。
Sheet"1/2层"的A3到G3汇集到Sheet"Chart"的C3到I3
Sheet"1/4层"的A3到G3汇集到Sheet"Chart"的C4到I4
Sheet"1/8层"的A3到G3汇集到Sheet"Chart"的C5到I5
Sheet"88层"的A3到G3汇集到Sheet"Chart"的C6到I6

所以想找老师们帮忙，请教一下，谢谢。

Henry D. Sy

sisusum 发表于 2017-7-15 10:08
首先谢谢你的代码，我要先下载用回看一下是不是这样子。

可能我讲得不够清楚，其实有4个工作表，分别叫( ...

忘了你还要求有序号
现在补上

1. Private Sub MergeTbl_Click()
   
2.     Dim arr(1 To 4) As String
   
3.     Dim tempArr()
   
4.     Dim i As Integer
   
5.     Dim j As Integer
   
6.     Dim k As Integer
   
7.     Dim m As Integer
   
8.     Dim intRows As Long
   
9.     Dim strSheetName As String
   
10.     Application.ScreenUpdating = False
    
11.     j = 1
    
12.     m = 1
    
13.     For i = 1 To ActiveWorkbook.Sheets.Count
    
14.         strSheetName = ActiveWorkbook.Sheets(i).Name
    
15.         Select Case Left(strSheetName, 1)
    
16.         Case "二", "四", "八", "8"
    
17.             arr(j) = strSheetName
    
18.             j = j + 1
    
19.         End Select
    
20.     Next
    
21.     intRows = (Worksheets(arr(1)).Range("A65536").End(xlUp).Row - 2) * UBound(arr)
    
22.     Range(Cells(2, 1), Cells(intRows + 1, 9)).ClearContents
    
23.     ReDim tempArr(1 To intRows, 1 To 8)
    
24.     Range("A2") = m
    
25.     For i = 1 To intRows
    
26.         k = i Mod UBound(arr)
    
27.         If k = 0 Then
    
28.             k = UBound(arr)
    
29.         End If
    
30.         tempArr(i, 1) = arr(k)
    
31.         For j = 2 To 8
    
32.             tempArr(i, j) = Worksheets(arr(k)).Cells(m + 2, j - 1)
    
33.         Next
    
34.         If i Mod UBound(arr) = 0 Then
    
35.             m = m + 1
    
36.             If m <= intRows / UBound(arr) Then
    
37.                 Range("A" & 2 + i) = m
    
38.             End If
    
39.         End If
    
40.     Next
    
41.     Range(Cells(2, 2), Cells(intRows + 1, 9)) = tempArr
    
42.     Application.ScreenUpdating = True
    
43. End Sub

复制代码

顺便说一下,为了测试,验证,四个基础表得第一列数量更改成有规律的数据.

sisusum

谢谢老师，刚下载了看看。但出现了错误，是以下这句。

tempArr(i, j) = Worksheets(arr(k)).Cells(m + 2, j - 1)


另外有一个问题，Sheet"1/2层"的A3、Sheet"1/4层"的A3、Sheet"1/8层"的A3、Sheet"88层"的A3都分别变成了A1到A77，原来的数值不见了？？

Henry D. Sy

sisusum 发表于 2017-7-16 23:29
谢谢老师，刚下载了看看。但出现了错误，是以下这句。

tempArr(i, j) = Worksheets(arr(k)).Cells(m + 2 ...

具体提示什么错误,

我上传的示例也提示错误?

另外有一个问题，Sheet"1/2层"的A3、Sheet"1/4层"的A3、Sheet"1/8层"的A3、Sheet"88层"的A3都分别变成了A1到A77，原来的数值不见了？？
可以再恢复回去呀,只是为了测试结果对错!

sisusum

我尝试用F8运行看看，马上跳出这错误，也没写明是错什麽，头晕呀。

对呀，直接下载了你上载的示例也是错误。

好吧，我直接把原来数值填上，但现在代码有问题不能运行却是一个问题，请帮忙解决，谢谢。

Henry D. Sy

sisusum 发表于 2017-7-17 00:30
我尝试用F8运行看看，马上跳出这错误，也没写明是错什麽，头晕呀。

对呀，直接下载了你上载的示例也是错 ...

--------------
-----------
--------

我这里正常呀

sisusum

老师，我回去再下载一次看看，如果还是有这问题，我截图给你看看，谢谢你的帮忙。

sisusum

Henry D. Sy 发表于 2017-7-17 09:14
--------------
-----------
--------

老师，我试了一遍还是不行，你能看看截图是出了什么问题吗？我用的是OFFICE 2016版本的，拜托！