Office中国论坛/Access中国论坛

标题: 如何写loop合併到工作表上 [打印本页]
作者: sisusum    时间: 2017-7-14 12:21
标题: 如何写loop合併到工作表上
老师们，我已经写了从第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    时间: 2017-7-14 21:43
是不是这个意思?
一条记录就得转换工作表吗???
  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
复制代码
[attach]61743[/attach]

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

可能我讲得不够清楚，其实有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    时间: 2017-7-15 10:17
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
复制代码
顺便说一下,为了测试,验证,四个基础表得第一列数量更改成有规律的数据.
[attach]61745[/attach]

作者: sisusum    时间: 2017-7-16 23:29
谢谢老师，刚下载了看看。但出现了错误，是以下这句。

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    时间: 2017-7-17 00:13
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    时间: 2017-7-17 00:30
我尝试用F8运行看看，马上跳出这错误，也没写明是错什麽，头晕呀。

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

好吧，我直接把原来数值填上，但现在代码有问题不能运行却是一个问题，请帮忙解决，谢谢。
作者: Henry D. Sy    时间: 2017-7-17 09:14
sisusum 发表于 2017-7-17 00:30
我尝试用F8运行看看，马上跳出这错误，也没写明是错什麽，头晕呀。

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

[attach]61757[/attach]
--------------
-----------
--------
[attach]61758[/attach]
我这里正常呀
作者: sisusum    时间: 2017-7-17 09:43
本帖最后由 sisusum 于 2017-7-17 23:32 编辑

老师，我回去再下载一次看看，如果还是有这问题，我截图给你看看，谢谢你的帮忙。
作者: sisusum    时间: 2017-7-17 23:30
Henry D. Sy 发表于 2017-7-17 09:14
--------------
-----------
--------

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

是不是chart表的结构跟我上传的不一样?
作者: Henry D. Sy    时间: 2017-7-17 23:54
你把chart工作表的上半部分截图上来看看
作者: sisusum    时间: 2017-7-18 10:42
Henry D. Sy 发表于 2017-7-17 23:54
你把chart工作表的上半部分截图上来看看

这是我从4#回覆上下了附件，打开了我就直接截图，看上去还正常，一到Merge这键就出现了错误，我没有更改什麽东西。
作者: Henry D. Sy    时间: 2017-7-18 11:12
sisusum 发表于 2017-7-18 10:42
这是我从4#回覆上下了附件，打开了我就直接截图，看上去还正常，一到Merge这键就出现了错误，我没有更改 ...

你的意思是,你直接运行四楼的附件,就出现问题,对吗?
如果是这样,我也不清楚了,因为这里一切正常,否则也就没有你最后的截图这种合并后的表了
作者: sisusum    时间: 2017-7-18 11:35
会不会是因为繁体版本的关係？这次真的头大了
作者: sisusum    时间: 2017-7-18 11:39
红框内的乱码会有影响吗？
作者: Henry D. Sy    时间: 2017-7-18 13:10
sisusum 发表于 2017-7-18 11:39
红框内的乱码会有影响吗？

不清楚
要不你把整个工作簿传上来看看(方便的话)
作者: sisusum    时间: 2017-7-18 13:29
好!!你看看试试，谢谢！
作者: sisusum    时间: 2017-7-18 13:30
方便加你QQ吗？
作者: Henry D. Sy    时间: 2017-7-18 13:32
sisusum 发表于 2017-7-18 13:29
好!!你看看试试，谢谢！

我一切正常呀

[attach]61772[/attach]




欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3