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

dambcer

Sub demo()
Dim sht As Worksheet, i As Long, s As Worksheet, k As Long, arr

If Sheets(1).Name <> "玻璃汇总" Then
    Set sht = Worksheets.Add(before:=Sheets(1))
    sht.Name = "玻璃汇总"
    Else
    Set sht = Sheets(1)
End If
k = 3
sht.Range("a2:e2") = Array("门名称", "玻璃宽/L", "玻璃高/H", "数量", "玻璃种类")
For Each s In Worksheets
    If IsNumeric(Right(s.Name, 2)) Then
        i = s.[o37].End(xlDown).Row
        s.[o38].Resize(i - 37, 4).Copy
        sht.Range("b" & k).Resize(i - 37, 1) = s.Name
        sht.Range("b" & k).PasteSpecial Paste:=xlPasteValues
        k = k + i - 37
    End If
Next s
sht.Columns("a:e").AutoFit
Set sht = Nothing
End Sub

cui26896

wangrh 发表于 2021-1-17 14:02
工作表的位置能不能放到任意位置，您这个现在不改代码的情况下只能放到第一位

本来你的表名就不规范，表格也非常的混乱，建议你好好看看这个帖，先把自己的基础工作做好，再来做代码。你现有表格的问题，比代码更重要！
对新手谈谈EXCEL用到的数据结构
http://club.excelhome.net/thread-1073526-1-1.html
(出处: ExcelHome技术论坛)

cui26896

wangrh 发表于 2021-1-17 14:02
工作表的位置能不能放到任意位置，您这个现在不改代码的情况下只能放到第一位

这个更简单了，Sheets(1)改成Sheets(“玻璃汇总”)就解决了。但你后面那些有单引号’的表名的位置必须从第7个表的位置开始到最后，因为这些表名都不规范，很难写代码来确定，因为听你说还在不断增加。用个数组也可以，但太长了不行。

xiangbaoan

Option Explicit
Sub test()
  Dim bm$, sq, cn, rs, i%, sh As Worksheet
  bm = "玻璃汇总"
  
  ActiveSht bm
  
  Set cn = CreateObject("ADODB.Connection")
  cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  For Each sh In Worksheets
    With sh
      If .Name <> bm Then
        If Trim(Replace(.Range("A1"), Space(1), "")) = "下料单" Then
          sq = sq & " union all select """ & .Range("b16") & """ AS 门窗代号,* from [" & .Name & "$o37:R43] where 数量 is not null"
        End If
      End If
    End With
  Next
  Set rs = cn.Execute(Mid(sq, 12))
  For i = 0 To rs.Fields.Count - 1
    Cells(2, i + 1) = rs.Fields(i).Name
  Next
  Range("a3").CopyFromRecordset rs
  
  SetFormats bm
End Sub

Function ActiveSht(ShtName As String) '设置工作表
  Dim sht As Worksheet
  On Error Resume Next
  Set sht = Worksheets(ShtName)
  If Err.Number <> 0 Then
    Set sht = Worksheets.Add
    ActiveSheet.Name = ShtName
    Err.Clear
  End If
  sht.Activate
  sht.Cells.Clear
End Function

Function SetFormats(ShtName As String) '设格式
  With Worksheets(ShtName).Range("a1")
    .Value = ShtName & "表"
    .Resize(, 5).Merge
    .Font.Bold = True
    With .CurrentRegion
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = 1
    End With
  End With
  Columns.AutoFit
  Beep
End Function

wangrh

cui26896 发表于 2021-1-17 14:28
这个更简单了，Sheets(1)改成Sheets(“玻璃汇总”)就解决了。但你后面那些有单引号’的表名的位置必须从 ...

完全解决了，我之前尝试这样改了的，但是不知道什么原因提示错误，现在没问题了，非常感谢你的耐心讲解。

wangrh

wangrh 发表于 2021-1-17 15:08
完全解决了，我之前尝试这样改了的，但是不知道什么原因提示错误，现在没问题了，非常感谢你的耐心讲解。 ...

1. 
   
2. Sub test2()
   
3. Dim arr, brr, i%, i2%, j%, tit, k
   
4.   Sheets.Add.Name = "玻璃汇总"
   
5.   tit = Array("门窗代号", "玻璃宽/L", "玻璃高/H", "数量", "玻璃种类")
   
6.   ReDim brr(1 To 50000, 1 To 5)
   
7.   For j = 0 To UBound(tit)
   
8.     brr(1, j + 1) = tit(j)
   
9.   Next
   
10.   k = k + 1
    
11.   For i2 = 7 To Sheets.Count
    
12.     With Sheets(i2)
    
13.       arr = .Range("o38:r43")
    
14.       For i = 1 To UBound(arr)
    
15.         If Len(arr(i, 1)) Then
    
16.           k = k + 1
    
17.           brr(k, 1) = .[b16]
    
18.           For j = 1 To UBound(arr, 2)
    
19.             brr(k, j + 1) = arr(i, j)
    
20.           Next
    
21.         End If
    
22.       Next
    
23.     End With
    
24.   Next
    
25.   With Sheets("玻璃汇总")
    
26.     .Range("a1").Resize(1000, 5).ClearContents
    
27.     .Range("a1").Resize(k, UBound(brr, 2)) = brr
    
28.   End With
    
29. End Sub
    

复制代码

我稍微修改了一下，致敬cui26896

cui26896

xiangbaoan 发表于 2021-1-17 15:00
Option Explicit
Sub test()
  Dim bm$, sq, cn, rs, i%, sh As Worksheet

我用的是四引号，结果显示有不能引用的字符，看来老师的三重引号是过了！

cui26896

老师真是太强大了，老师提示那帖，我走了弯路，想用ADOX.Catalog的Columns属性去确定字段名，走偏了。本帖，想到有特殊符号要用多重引号，但用了""""四引号，结果又走偏了。

wangrh

xiangbaoan 发表于 2021-1-17 15:00
Option Explicit
Sub test()
  Dim bm$, sq, cn, rs, i%, sh As Worksheet

感谢xiangbaoan老师，现在才看到您的回复，完美解决

xiangbaoan

cui26896 发表于 2021-1-17 17:06
老师真是太强大了，老师提示那帖，我走了弯路，想用ADOX.Catalog的Columns属性去确定字段名，走偏了。本帖 ...

老师好！共同学习。