[已解决]修改代碼.從把全部資料從所有分表匯總.變更為改為只取得特定行

X.Z.

各位好:
下面的代碼是把把從 128~150的sheet 匯整到 All_Total sheet
想請問我只需要第2行的資料 目前沒有資料的SHEET不要匯入
謝謝

1.      Sub test()
   
2.        ThisWorkbook.Sheets("All_Total").Range("a2:z1000").ClearContents '清除指定範圍
   
3.         For i = 128 To 150    '工作表的數量(名稱)
   
4.         For J = 2 To 2        '行數的數量
   
5.         a = Sheets("All_Total").[a65536].End(xlUp).Row + 1
   
6.         Sheets("All_Total").Cells(a, 1) = "192.168." & Sheets("" & i & "").Name & ".0" '彙總表的第一列寫入各工作表的名稱
   
7.         For S = 2 To 100                                                               '工作表的欄數
   
8.         Sheets("All_Total").Cells(a, S) = Sheets("" & i & "").Cells(J, S)              '工作表的各列彙總到一張表
   
9.         Sheets("All_Total").Cells(a, 13) = Left("00" & Sheets("All_Total").Cells(a, 2), Len(0 & Sheets("All_Data").Cells(a, 2)))
   
10.         Next
    
11.         Next
    
12.         Next
    
13.     End Sub

复制代码

目前有資料的SHEET



希望的結果

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-13 09:22

1. Sub test()
   
2.     Dim i&, a&, k&
   
3.     Application.ScreenUpdating = False
   
4.     Worksheets("All_Total").Activate
   
5.     Range("a2:z1000").ClearContents '清除指定範圍
   
6.     For i = 128 To 150    '工作表的數量(名稱)
   
7.         a = [a65536].End(xlUp).Row + 1
   
8.         With Worksheets("" & i & "")
   
9.             k = .[a65536].End(xlUp).Row
   
10.             If k > 1 Then
    
11.                 .Rows(2).Copy Rows(a)
    
12.                 Application.CutCopyMode = False
    
13.                 Cells(a, 1) = "192.168." & .Name & ".0"
    
14.                 Cells(a, 13) = Left("00" & Cells(a, 2), Len(0 & Cells(a, 2)))
    
15.             End If
    
16.         End With
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub

复制代码

这样就可以了呀，我刚试了，呆会把附件传上来你看看。

跳转到最佳答案楼层

hwc2ycy

1. Sub test()
   
2.     Dim i&, a&, k&
   
3.     Application.ScreenUpdating = False
   
4.     Worksheets("All_Total").Activate
   
5.     Range("a2:z1000").ClearContents '清除指定範圍
   
6.     For i = 128 To 150    '工作表的數量(名稱)
   
7.         a = [a65536].End(xlUp).Row + 1
   
8.         With Worksheets("" & i & "")
   
9.             k = .[a65536].End(xlUp).Row
   
10.             If k > 1 Then
    
11.                 .Rows(2).Copy Rows(a)
    
12.                 Application.CutCopyMode = False
    
13.                 Range("a2") = "192.168." & .Name & ".0"
    
14.                 Cells(a, 13) = Left("00" & Cells(a, 2), Len(0 & Cells(a, 2)))
    
15.             End If
    
16.         End With
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

X.Z.

hwc2ycy 发表于 2012-12-13 08:45

hwc2ycy 早上好
感謝您 這個快速地協助

第二行的資料有誤!! 可以再幫忙修改一下嗎?
謝謝

hwc2ycy

1. Range("a2") = "192.168." & .Name & ".0"

复制代码

，这里好像写错了，
应该是

1. cell(a,1) = "192.168." & .Name & ".0"

复制代码

hwc2ycy

你把你的附件传上来，我是凭看着的印象写的。

hwc2ycy

1. Sub test()
   
2.     Dim i&, a&, k&
   
3.     Application.ScreenUpdating = False
   
4.     Worksheets("All_Total").Activate
   
5.     Range("a2:z1000").ClearContents '清除指定範圍
   
6.     For i = 128 To 150    '工作表的數量(名稱)
   
7.         a = [a65536].End(xlUp).Row + 1
   
8.         With Worksheets("" & i & "")
   
9.             k = .[a65536].End(xlUp).Row
   
10.             If k > 1 Then
    
11.                 .Rows(2).Copy Rows(a)
    
12.                 Application.CutCopyMode = False
    
13.                 Cells(a, 1) = "192.168." & .Name & ".0"
    
14.                 Cells(a, 13) = Left("00" & Cells(a, 2), Len(0 & Cells(a, 2)))
    
15.             End If
    
16.         End With
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub

复制代码

这样就可以了呀，我刚试了，呆会把附件传上来你看看。

hwc2ycy

bandwithd - 1.rar (59.96 KB, 下载次数: 16)

2012-12-13 09:23 上传

点击文件名下载附件

X.Z.

hwc2ycy 发表于 2012-12-13 09:23

謝謝您!!

Range("a2") = "192.168." & .Name & ".0"
這行的差異對吧
Cells(a, 1) = "192.168." & .Name & ".0"

X.Z.

可以再請問一下嗎?
想要修改為不要用active的方式改採指定頁面的方式這樣改的話
我測試過 這樣改是可以達到! 只是想問問 有沒有更好的方式!
謝謝

1. Sub test()
   
2.     Dim i&, a&, k&
   
3.     Application.ScreenUpdating = False
   
4.     Worksheets("All_Total").Range("a2:z1000").ClearContents '清除指定範圍
   
5.      For i = 128 To 150    '工作表的數量(名稱)
   
6.         a = Worksheets("All_Total").[a65536].End(xlUp).Row + 1
   
7.         With Worksheets("" & i & "")
   
8.             k = .[a65536].End(xlUp).Row
   
9.             If k > 1 Then
   
10.                 .Rows(2).Copy Worksheets("All_Total").Rows(a)
    
11.                 Application.CutCopyMode = False
    
12.                 Worksheets("All_Total").Cells(a, 1) = "192.168." & .Name & ".0"
    
13.                 'Cells(a, 13) = Left("00" & Cells(a, 2), Len(0 & Cells(a, 2)))
    
14.             End If
    
15.         End With
    
16.     Next
    
17.     Application.ScreenUpdating = True
    
18. End Sub

复制代码

hwc2ycy

那就用WITH嘛。
除非你能保证当前打开的就是ALL_TOTAL表