如何写loop合併到工作表上

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
    

复制代码

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

复制代码

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

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，原来的数值不见了？？
可以再恢复回去呀,只是为了测试结果对错!

Henry D. Sy

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

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

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

我这里正常呀

Henry D. Sy

sisusum 发表于 2017-7-17 23:30
老师，我试了一遍还是不行，你能看看截图是出了什么问题吗？我用的是OFFICE 2016版本的，拜托！

是不是chart表的结构跟我上传的不一样?

Henry D. Sy

你把chart工作表的上半部分截图上来看看

Henry D. Sy

sisusum 发表于 2017-7-18 10:42
这是我从4#回覆上下了附件，打开了我就直接截图，看上去还正常，一到Merge这键就出现了错误，我没有更改 ...

你的意思是,你直接运行四楼的附件,就出现问题,对吗?
如果是这样,我也不清楚了,因为这里一切正常,否则也就没有你最后的截图这种合并后的表了

Henry D. Sy

sisusum 发表于 2017-7-18 11:39
红框内的乱码会有影响吗？

不清楚
要不你把整个工作簿传上来看看(方便的话)

Henry D. Sy

sisusum 发表于 2017-7-18 13:29
好!!你看看试试，谢谢！

我一切正常呀