工作表数据汇总求VBA代码

kfjqlei

LIUZHU 发表于 2022-11-25 11:15
数据再次，请测试，WPS软件

里面没代码啊

于箱长

kfjqlei 发表于 2022-11-25 11:38
可否给我附件朋友

自己录一遍吧，正好学习一下

3190496160

Sub 按钮1_Click()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("数据A")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For j = 1 To UBound(ar, 2)
    If Trim(ar(1, j)) <> "" Then
        d(Trim(ar(1, j))) = j
    End If
Next j
With Sheets("数据B")
    rb = .Cells(Rows.Count, 1).End(xlUp).Row
    yb = .Cells(1, Columns.Count).End(xlToLeft).Column
    br = .Range(.Cells(1, 1), .Cells(rb, yb))
End With
ReDim arr(1 To UBound(ar) + UBound(br) + 1000, 1 To UBound(ar, 2) + UBound(br, 2))
yy = 1
arr(1, 1) = "数据源"
For j = 1 To UBound(br, 2)
    n = 1
    If Trim(br(1, j)) <> "" Then
        lh = d(Trim(br(1, j)))
        If lh <> "" Then
            yy = yy + 1
            arr(1, yy) = br(1, j)
            For i = 2 To UBound(ar)
                n = n + 1
                arr(n, yy) = ar(i, lh)
                arr(n, 1) = "数据A"
            Next i
            For i = 2 To UBound(br)
                n = n + 1
                arr(n, yy) = br(i, j)
                arr(n, 1) = "数据B"
            Next i
        End If
    End If
Next j
With Sheets("汇总")
    .[a1].CurrentRegion = Empty
    If yy = 1 Or n = 1 Then MsgBox "没有需要提取的数据！": End
    .[a1].Resize(n, yy) = arr
End With
Set d = Nothing
MsgBox "ok!"
End Sub

3190496160

表格数据汇总.rar (25.31 KB, 下载次数: 16)

2022-11-25 12:11 上传

点击文件名下载附件

3190496160

这个问题看似简单，其实并不简单，看看是不是你需要的效果吧

3190496160

wps要点击这个 按钮切换到js环境下才能看到代码

fzxba

1. Sub 按钮1_Click()
   
2.   Dim Conn As Object, rs As Object, Sht As Worksheet
   
3.   Dim strConn As String, SQL As String, i As Integer
   
4.   Set Conn = CreateObject("ADODB.Connection")
   
5.   If Application.Version < 12 Then
   
6.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;IMEX=1';Data Source="
   
7.   Else
   
8.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;IMEX=1';Data Source="
   
9.   End If
   
10.   Conn.Open strConn & ThisWorkbook.FullName
    
11.   For Each Sht In Worksheets
    
12.     With Sht
    
13.       If .Name <> "汇总" Then
    
14.         SQL = SQL & " UNION ALL SELECT AA,BB,AB,AF,CD,'" & .Name & "' AS 数据源 FROM [" & .Name & "$" & .Range("A1").CurrentRegion.Address(0, 0) & "]"
    
15.       End If
    
16.     End With
    
17.   Next
    
18.   Set rs = Conn.Execute(Mid(SQL, 12))
    
19.   With Worksheets("汇总").Range("A1")
    
20.     .CurrentRegion.Offset(1).ClearContents
    
21.     For i = 0 To rs.Fields.Count - 1
    
22.       .Offset(0, i) = rs.Fields(i).Name
    
23.     Next
    
24.     .Offset(1).CopyFromRecordset rs
    
25.   End With
    
26.   Set rs = Nothing
    
27.   Conn.Close
    
28.   Set Conn = Nothing
    
29.   Beep
    
30. End Sub

复制代码

LIUZHU

kfjqlei 发表于 2022-11-25 11:39
里面没代码啊

WPS软件，切换到JS宏，JS的数组比VBA强大太多

kfjqlei

于箱长 发表于 2022-11-25 11:52
自己录一遍吧，正好学习一下

唉，年龄大了学不进去啦

kfjqlei

LIUZHU 发表于 2022-11-25 14:21
WPS软件，切换到JS宏，JS的数组比VBA强大太多

哦，那是不是Office用户 用不了