|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Option Explicit
- Sub test0()
- Dim ar, Conn As Object, rs As Object, i As Long
- Dim strSQL As String, SQL As String, strConn As String
- Dim tab_ As String, class_ As String, pivot_ As String
-
- Set Conn = CreateObject("ADODB.Connection")
- If Application.Version < 12 Then
- strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
- Else
- strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
- End If
- Conn.Open strConn & ThisWorkbook.FullName
-
- With Sheet1
- tab_ = .Name & "$" & .Range("A1").CurrentRegion.Address(0, 0)
- class_ = .Range("A1").Value
- ar = .Range("M1").CurrentRegion.Resize(2).Value
- End With
-
- SQL = "SELECT " & class_ & ",'-ar(1,i)' AS 科目 ,-ar(1,i) AS 成绩 FROM [" & tab_ & "] WHERE -ar(1,i)>=-ar(2,i)"
- For i = 2 To UBound(ar, 2)
- strSQL = strSQL & " UNION ALL " & Replace(Replace(SQL, "-ar(1,i)", ar(1, i)), "-ar(2,i)", ar(2, i))
- pivot_ = pivot_ & ",'" & ar(1, i) & "'"
- Next
- strSQL = Mid(strSQL, 12) & Replace(strSQL, class_, "'总计'")
-
- strSQL = "TRANSFORM COUNT(成绩) SELECT " & class_ & " FROM (" & strSQL & ") GROUP BY " & class_ & " PIVOT 科目 IN (" & Mid(pivot_, 2) & ")"
- Set rs = Conn.Execute(strSQL)
-
- With Sheet1.Range("M1")
- .CurrentRegion.Offset(2).ClearContents
- For i = 0 To rs.Fields.Count - 1
- .Offset(, i) = rs.Fields(i).Name
- Next
- .Offset(2).CopyFromRecordset rs
- End With
-
- rs.Close
- Set rs = Nothing
- Conn.Close
- Set Conn = Nothing
- Beep
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|