把多表格相同位置单元格汇总到一张新的工作表中

wangrh

lsc900707 发表于 2021-1-17 08:08
简单的数组问题。

lsc900707版主，感谢你的关注，对于高手来说肯定简单，但对于我们这种小白来说就难了

cui26896

Sub test2()
Dim arr, brr, i%, i2%, j%, tit, k
  tit = Array("门窗代号", "玻璃宽/L", "玻璃高/H", "数量", "玻璃种类")
  ReDim brr(1 To 50000, 1 To 5)
  For j = 0 To UBound(tit)
    brr(1, j + 1) = tit(j)
  Next
  k = k + 1
  For i2 = 7 To Sheets.Count
    With Sheets(i2)
      arr = .Range("o38:r43")
      For i = 1 To UBound(arr)
        If Len(arr(i, 1)) Then
          k = k + 1
          brr(k, 1) = Sheets(i2).Name
          For j = 1 To UBound(arr, 2)
            brr(k, j + 1) = arr(i, j)
          Next
        End If
      Next
    End With
  Next
  With Sheets(1)
    .Range("a2").Resize(100, 5).ClearContents
    .Range("a2").Resize(k, UBound(brr, 2)) = brr
  End With
End Sub

wangrh

Sub Macro2()
    Dim arr, brr(1 To 65530, 1 To 5), sh As Worksheet, i&, j&, m&
    For Each sh In Sheets
        If InStr(sh.Name, "汇总表") = 0 And sh.Name <> "型材参数" And sh.Visible = xlSheetVisible Then
            arr = sh.[o38:s43]
            For i = 38 To UBound(arr)
                If Len(arr(i, 1)) Then
                    m = m + 1
                    brr(m, 1) = arr(16, 2)
                    For j = 15 To 19
                        brr(m, j + 1) = arr(i, j)
                    Next
                    
                End If
            Next
        End If
    Next
    With Sheets("玻璃汇总")
        .Range("A3:g65536").ClearContents
        .[a3].Resize(m, 5) = brr
    End With
End Sub
我自己编了半天，还是不行

wangrh

1. Sub Macro2()
   
2.     Dim arr, brr(1 To 65530, 1 To 7), sh As Worksheet, i&, j&, m&
   
3.     For Each sh In Sheets
   
4.         If InStr(sh.Name, "汇总表") = 0 And sh.Name <> "型材参数" And sh.Visible = xlSheetVisible Then
   
5.             arr = sh.[o38:s43]
   
6.             For i = 38 To UBound(arr)
   
7.                 If Len(arr(i, 1)) Then
   
8.                     m = m + 1
   
9.                     brr(m, 1) = arr(16, 2)
   
10.                     For j = 15 To 19
    
11.                         brr(m, j + 1) = arr(i, j)
    
12.                     Next
    
13.                     
    
14.                 End If
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     With Sheets("玻璃汇总")
    
19.         .Range("A3:g65536").ClearContents
    
20.         .[a3].Resize(m, 5) = brr
    
21.     End With
    
22. End Sub

复制代码

还是不行，

cui26896

天冷手僵，用SQL语句，你的那些个表名不合规范，无法用，除非要改表名。只有凑一个最简单的，没有什么字典。
下料单A.zip (35.38 KB, 下载次数: 5)

2021-1-17 13:18 上传

点击文件名下载附件

wangrh

cui26896 发表于 2021-1-17 13:18
天冷手僵，用SQL语句，你的那些个表名不合规范，无法用，除非要改表名。只有凑一个最简单的，没有什么字典 ...

非常感谢cui26896老师，汇总没有问题，你统计门窗代号是用的工作表名称，我原本是想用B16单元格的代号。

wangrh

1. 
   

复制代码

wangrh

我自己也写了个代码，但是一直不对

cui26896

wangrh 发表于 2021-1-17 13:38
非常感谢cui26896老师，汇总没有问题，你统计门窗代号是用的工作表名称，我原本是想用B16单元格的代号。

这个很好办，把brr(k, 1) = Sheets(i2).Name改成brr(k, 1) = .[b16]就Ok了

wangrh

cui26896 发表于 2021-1-17 13:43
这个很好办，把brr(k, 1) = Sheets(i2).Name改成brr(k, 1) = .就Ok了

工作表的位置能不能放到任意位置，您这个现在不改代码的情况下只能放到第一位