把信息汇总到一个总表？

jiaqitang

工作簿有几个表，是各地区的付款记录，虽然列数不同，但格式是相同的，并且都有几个共同列。 我想做个汇总表，把各地区数据根据列名汇集到这个表里，如果某地区数据没这列，就显示空值即可。加了一个首列来显示地区表名。 因为地区表有很多，列数也是不同，简单的复制粘贴太费时间，想用VBA实现，怎么做呢？ 请看附件

xiangbaoan

Option Explicit

Sub test()
  Dim ar, br, cr&(), d As Object, i&, j&, x&, y&, sh As Worksheet, s$
  Set d = CreateObject("Scripting.Dictionary")
  With Worksheets(1)
    .UsedRange.Offset(1).ClearContents
    ar = .Range("a1").CurrentRegion.Resize(9999)
  End With
  For j = 2 To UBound(ar, 2)
    If Len(ar(1, j)) Then d(ar(1, j)) = j
  Next
  y = 1
  For Each sh In Worksheets
    If sh.Index > 1 Then
      x = 0
      s = sh.Name
      br = sh.Range("a1").CurrentRegion
      For j = 1 To UBound(br, 2)
        If d.Exists(br(1, j)) Then
          x = x + 1
          ReDim Preserve cr(1 To 2, 1 To x)
          cr(1, x) = j
          cr(2, x) = d(br(1, j))
        End If
      Next
      For i = 2 To UBound(br)
          y = y + 1
          ar(y, 1) = s
          For j = 1 To x
            ar(y, cr(2, j)) = br(i, cr(1, j))
          Next
      Next
    End If
  Next
  Worksheets(1).Range("a1").Resize(y, UBound(ar, 2)) = ar
  Set d = Nothing
End Sub

xiangbaoan

payment.rar (37.38 KB, 下载次数: 19)

2021-1-16 15:38 上传

点击文件名下载附件

xiangbaoan

1. Option Explicit
   
2. 
   
3. Sub test2()
   
4.   Dim ar, cr, dr, j&, x&, Sq$
   
5.   Dim d As Object, Cn As Object, sh As Worksheet
   
6.   With Worksheets(1)
   
7.     .UsedRange.Offset(1).ClearContents
   
8.     ar = .[b1:o1 & ""]
   
9.   End With
   
10.   ReDim br$(1 To UBound(ar))
    
11.   Set d = CreateObject("Scripting.Dictionary")
    
12.   For j = 1 To UBound(ar)
    
13.     d(ar(j)) = j
    
14.     ar(j) = "[" & ar(j) & "]"
    
15.     br(j) = "NULL"
    
16.   Next
    
17.   Set Cn = CreateObject("ADODB.Connection")
    
18.   Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    
19.   For Each sh In Worksheets
    
20.     With sh
    
21.       If .Index > 1 Then
    
22.         cr = br
    
23.         dr = .Range("a1").CurrentRegion.Resize(1)
    
24.         For j = 1 To UBound(dr, 2)
    
25.           x = d(dr(1, j)): If x Then cr(x) = ar(x)
    
26.         Next
    
27.         Sq = Sq & " UNION ALL SELECT '" & .Name & "' AS Location," & Join(cr, ",") & " FROM[" & .Name & "$" & .Range("a1").CurrentRegion.Address(0, 0) & "]"
    
28.       End If
    
29.     End With
    
30.   Next
    
31.   Worksheets(1).Range("a2").CopyFromRecordset Cn.Execute(Mid(Sq, 12))
    
32.   Set d = Nothing: Cn.Close: Set Cn = Nothing
    
33. End Sub

复制代码

jiaqitang

太感谢了，两种方法，sql 也有

jiaqitang

我又在表中多加了几列数据，期中有日期。出现运行错误

VBA报错run-time error'6' overflow，debug错误出现在这行
  br = sh.Range("a1").CurrentRegion

我又全选数据表，右键选单元格格式-选通用。 再运行就可以了。

怎么改code？不想每次加了新数据，还要再改单元格格式。

谢谢

cui26896

jiaqitang 发表于 2021-1-17 11:09
我又在表中多加了几列数据，期中有日期。出现运行错误

VBA报错run-time error'6' overflow，debug错误出 ...

新增加的列名必须在汇总表的第一行中加上，运行应该没有问题。

babobo

Sub test()

Application.ScreenUpdating = False
Dim sh As Worksheet
r = Sheets("汇总").Range("A65536").End(xlUp).Row + 2
Sheets("汇总").Rows("2:" & r) = ""
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source =" & ThisWorkbook.FullName
  For Each sh In Worksheets
    If sh.Index > 1 Then
      s = sh.Name
      t = "[" & s & "$A1:Z]"
      Sql = "select * from" & t
      r = Sheets("»ã×ü").Range("A65536").End(xlUp).Row + 1
      Sheets("»ã×ü").Range("A" & r).CopyFromRecordset cnn.Execute(Sql)
    End If
  Next
cnn.Close
Set cnn = Nothing

End Sub