请大神简化代码

coconoiz

请大神们帮我看下，怎么样简化代码，我只是想把多个表格中固定位置的数据汇总展示到一张表上。

Sub Data_()

Dim i As Single

For i = 1 To Worksheets.Count

Cells(i + 1, 2) = Worksheets(i).Cells(4, 1)

Next

End Sub

Sub Data2_()

Dim a As Single

For a = 1 To Worksheets.Count

Cells(a + 1, 3) = Worksheets(a).Cells(4, 2)

Next

End Sub

Sub Data3_()

Dim b As Single

For b = 1 To Worksheets.Count

Cells(b + 1, 4) = Worksheets(b).Cells(4, 3)

Next

End Sub

Sub Data4_()

Dim c As Single

For c = 1 To Worksheets.Count

Cells(c + 1, 5) = Worksheets(c).Cells(5, 1)

Next

End Sub

Sub Data5_()

Dim d As Single

For d = 1 To Worksheets.Count

Cells(d + 1, 6) = Worksheets(d).Cells(5, 2)

Next

End Sub

Sub Data6_()

Dim e As Single

For e = 1 To Worksheets.Count

Cells(e + 1, 7) = Worksheets(e).Cells(5, 3)

Next

End Sub

Sub Data7_()

Dim f As Single

For f = 1 To Worksheets.Count

Cells(f + 1, 8) = Worksheets(f).Cells(6, 1)

Next

End Sub

Sub Data8_()

Dim j As Single

For j = 1 To Worksheets.Count

Cells(j + 1, 9) = Worksheets(j).Cells(6, 2)

Next

End Sub

Sub Data9_()

Dim h As Single

For h = 1 To Worksheets.Count

Cells(h + 1, 10) = Worksheets(h).Cells(6, 3)

Next

End Sub

taller

参考代码

1. Sub Data()
   
2.     Dim i As Single, j As Integer
   
3.     For i = 1 To Worksheets.Count
   
4.         For j = 2 To 10
   
5.             Cells(i + 1, 2) = Worksheets(i).Range(Range("A4:C6").Cells(j - 1).Address)
   
6.         Next
   
7.     Next
   
8. End Sub

复制代码

coconoiz

taller 发表于 2020-2-18 02:55
参考代码

谢谢，可是运行后只输出了一列数据，可以麻烦您再查看下么?

mzbao

1. Sub Data_()
   
2.     Dim i As Single, r%, c%, k%
   
3.     k = 1
   
4.     For i = 1 To Worksheets.Count
   
5.         For r = 4 To 6
   
6.             For c = 1 To 3
   
7.                 k = k + 1
   
8.                 Cells(i + 1, k) = Worksheets(i).Cells(r, c)
   
9.             Next c
   
10.         Next r
    
11.     Next
    
12. End Sub

复制代码

microyip

1. Sub Data()
   
2.     Dim wSH As Worksheet, nSheet As Integer
   
3.     Dim vData As Variant, nRow As Integer, nCol As Integer, vFill As Variant
   
4.    
   
5.     ReDim vData(1 To Sheets.Count)
   
6.     ReDim vFill(1 To Sheets.Count, 2 To 10)
   
7.     For Each wSH In Sheets
   
8.         nSheet = nSheet + 1
   
9.         vData(nSheet) = wSH.[A4:C6].Value
   
10.     Next
    
11.     For nSheet = 1 To UBound(vData)
    
12.         For nRow = 1 To UBound(vData(nSheet))
    
13.             For nCol = 1 To UBound(vData(nSheet), 2)
    
14.                 vFill(nSheet, Int((nRow - 1) / 3) * 3 + nCol) = vData(nSheet)(nRow, nCol)
    
15.             Next
    
16.         Next
    
17.     Next
    
18.     [B2].Resize(UBound(vFill), UBound(vFill, 2)) = vFill
    
19. End Sub

复制代码

taller

coconoiz 发表于 2020-2-18 12:39
谢谢，可是运行后只输出了一列数据，可以麻烦您再查看下么?

1. Sub Data()
   
2.     Dim i As Single, j As Integer, n, col
   
3.     For i = 1 To Worksheets.Count
   
4.         col = 2
   
5.         n = 1
   
6.         For j = 2 To 10
   
7.             If n > 3 Then
   
8.                 n = 1: col = col + 1
   
9.             End If
   
10.             Cells(i + 1, col) = Worksheets(i).Range(Range("A4:C6").Cells(j - 1).Address)
    
11.             n = n + 1
    
12.         Next
    
13.     Next
    
14. End Sub

复制代码

coconoiz

taller 发表于 2020-2-18 13:35

谢谢帮助，您的帮助十分有用，只是和我自己之前的代码出来的效果有所不同。还请您可以在文件中看下么？

这个文件中我自己写的简陋的代码代码在this workbook中，自己最终效果在“coco的汇总”，只是改了下单元格位置。因为实践中我需要把所有绿色的部分都提取登记，不止9个单位格。

coconoiz

microyip 发表于 2020-2-18 13:10

谢谢帮助，您的语言水平很高，中间有一部分我还没有学习到，但对我帮助很大。只是和我自己之前的代码出来的效果有所不同。还请您可以在文件中看下么？
这个文件中我自己写的简陋的代码代码在this workbook中，自己最终效果在“coco的汇总”，只是改了下单元格位置。因为实践中我需要把所有绿色的部分（I1：K22）都提取登记，不止9个单位格。

coconoiz

mzbao 发表于 2020-2-18 12:51

谢谢帮助，您的帮助十分有用，只是和我自己之前的代码出来的效果有所不同。还请您可以在文件中看下么？

这个文件中我自己写的简陋的代码代码在this workbook中，自己最终效果在“coco的汇总”，只是改了下单元格位置。因为实践中我需要把所有绿色的部分（I1：K22）都提取登记，不止9个单位格。

microyip

1. Sub Data()
   
2.     Dim wSH As Worksheet, nSheet As Integer
   
3.     Dim vData As Variant, nRow As Integer, nCol As Integer, vFill As Variant
   
4.    
   
5.     With Sheet13
   
6.         ReDim vFill(1 To 9, 0)
   
7.         For Each wSH In Sheets
   
8.             If wSH.Name <> .Name Then
   
9.                 nSheet = UBound(vFill, 2) + 1
   
10.                 ReDim Preserve vFill(1 To UBound(vFill), 1 To nSheet)
    
11.                 vData = wSH.[I1:K3].Value
    
12.                 For nRow = 1 To UBound(vData)
    
13.                     For nCol = 1 To UBound(vData, 2)
    
14.                         vFill((nRow - 1) * 3 + nCol, nSheet) = vData(nRow, nCol)
    
15.                     Next
    
16.                 Next
    
17.             End If
    
18.         Next
    
19.         .[B2].Resize(UBound(vFill, 2), UBound(vFill)) = Application.WorksheetFunction.Transpose(vFill)
    
20.     End With
    
21. End Sub

复制代码