求大神帮忙用VBA将1表和2表生成3表数据，感谢感谢

chinasun0

求大神帮忙用VBA将1表和2表生成3表数据，感谢感谢

ovxyz

fzxba

用VBA将1表和2表生成3表中数据.rar (20.77 KB, 下载次数: 19)

2023-2-17 17:07 上传

点击文件名下载附件

剑指E

ovxyz

其实如果非必要，也没有必要用vba，公式就可以解决。
=INDIRECT("'1'!A"&(INT((ROW(C1)-1)/4)+2))
=SUBSTITUTE(OFFSET(INDIRECT("'2'!B1"),0,MOD(ROW(C1)-1,4)),"占比","")
=INDIRECT("'1'!B"&(INT((ROW(C1)-1)/4)+2))*OFFSET(INDIRECT("'2'!B"&(INT((ROW(C1)-1)/4)+2)),0,MOD(ROW(C1)-1,4))

chinasun0

ovxyz 发表于 2023-2-17 16:52

感谢您的帮助

chinasun0

fzxba 发表于 2023-2-17 17:07

感谢您的帮助

chinasun0

剑指E 发表于 2023-2-17 17:12

感谢您的帮助

fzxba

1. Sub test1() '加一方法
   
2.   Dim ar, br, Conn As Object
   
3.   Dim SQL As String, strConn As String, tb As String, i As Long
   
4.   
   
5.   If Application.Version < 12 Then
   
6.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
   
7.   Else
   
8.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
   
9.   End If
   
10.   Set Conn = CreateObject("ADODB.Connection")
    
11.   Conn.Open strConn & ThisWorkbook.FullName
    
12.   
    
13.   With Worksheets(2).Range("A1").CurrentRegion
    
14.     ar = Application.Rept(.Rows(1), 1)
    
15.     tb = .Parent.Name & "$" & .Address(0, 0)
    
16.   End With
    
17.   For i = 2 To UBound(ar)
    
18.     SQL = SQL & " UNION ALL SELECT " & ar(1) & ",'" & ar(i) & "' AS 科目," & ar(i) & " AS 占比 FROM [" & tb & "]"
    
19.   Next
    
20.   
    
21.   With Worksheets(1).Range("A1").CurrentRegion
    
22.     br = WorksheetFunction.Transpose(Intersect(.Columns(1), .Columns(1).Offset(1)))
    
23.     tb = .Parent.Name & "$" & .Address(0, 0)
    
24.   End With
    
25.   SQL = "SELECT b.班级,a.科目,b.总成绩*a.占比 AS 成绩 " & _
    
26.         "FROM (" & Mid(SQL, 12) & ") a RIGHT JOIN [" & tb & "] b " & _
    
27.         "ON a.班级=b.班级 " & _
    
28.         "ORDER BY INSTR('" & Join(br, ",") & "',b.班级),INSTR('" & Join(ar, ",") & "',a.科目)"
    
29.   
    
30.   With Worksheets(3).Range("A1")
    
31.     .CurrentRegion.ClearContents
    
32.     .Resize(, 3) = Split("班级 科目 成绩")
    
33.     .Offset(1).CopyFromRecordset Conn.Execute(SQL)
    
34.     .CurrentRegion.Columns(2).Replace "占比", "", xlPart
    
35.   End With
    
36.   
    
37.   Conn.Close
    
38.   Set Conn = Nothing
    
39.   Beep
    
40. End Sub

复制代码

chinasun0

fzxba 发表于 2023-2-17 17:07

用VBA的方法将表1和表2生成表3格式                               
1-N班表1和表2均有，表1中总分*表2中各科占比（已实现）                               
Z班和X班表2中没有，表3中B列显示总成绩字符，C列显示表1的总成绩（待补充）                               
                               
右侧代码中仅保留了表1和表2都有的部分，但是表1中没有的部分就删除了，现在想保留下来，求大神帮忙看看怎么调整。感激不尽（应该是调整右侧表中Beep部分）