Excel VBA 与 SQL 语言的综合运用

Excel 中使用VBA可以极大地提高工作效率，如果将VBA与SQL语言（Structured Query Language，简称SQL）结合起来使用，处理数据起来那更是如鱼得水，如虎添翼，锦上添花。可喜可贺的是，该语言简洁，易学易用，可以嵌套，具有极大的灵活性和强大的功能。今天我带你领略VBA与SQL语言汇总数据的风采。

一、基础数据（原始数据）

图1 用工费

二、汇总数据表

图2 汇总数据表

三、模块代码

1、VBA之字典汇总，代码如下：

Sub dic_groupby()

Dim arr,t

Dim d As New Dictionary

Dim i As Integer, k%, j%

Dim sh1 As Worksheet, sh2 As Worksheet

Set d = CreateObject('Scripting.Dictionary')

'创建字典

Set sh1 = Sheets('总表')

Set sh2 = Sheets('用工费')

arr = sh2.Range('a1').CurrentRegion

sh1.Range('a1:f500').ClearContents

sh1.[a1:g1] = Array('id', 'name', 'corn', 'millet', 'rapeseed', 'other', 'ALL')

For i = 2 To UBound(arr)

If d.Exists(arr(i, 2)) Then

d(arr(i, 2)) = Array(d(arr(i, 2))(0) + arr(i, 3), d(arr(i, 2))(1) + arr(i, 4), d(arr(i, 2))(2) + arr(i, 5), d(arr(i, 2))(3) + arr(i, 6))

Else

d(arr(i, 2)) = Array(arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))

End If

Next i

'通过循环进行汇总

t = d.Keys

t = WorksheetFunction.Transpose(t)

'对字典的键进行转置

sh1.[b2].Resize(d.Count) =t

'将字典的键放入sh1里面的b2单元格起始的位置，行扩展数量为d.count，默认一列。

sh1.[C2].Resize(d.Count, 4) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items))

'对字典的键对应的数值进行双重转置后放入C2单元格起始的位置，行扩展数量为d.count,4列。

sh1.Range('a' & d.Count + 2).Offset(0, 2) = WorksheetFunction.Sum(Range('C2:C' & d.Count + 1))

sh1.Range('a' & d.Count + 2).Offset(0, 3) = WorksheetFunction.Sum(Range('D2:D' & d.Count + 1))

sh1.Range('a' & d.Count + 2).Offset(0, 4) = WorksheetFunction.Sum(Range('E2:E' & d.Count + 1))

sh1.Range('a' & d.Count + 2).Offset(0, 5) = WorksheetFunction.Sum(Range('F2:F' & d.Count + 1))

'对相应的列求和计算

For j = 1 To d.Count

sh1.Range('a' & j + 1) = j

sh1.Range('G' & j + 1) = WorksheetFunction.Sum(Range('C' & j + 1 & ':F' & j + 1))

Next j

'行方向求和

sh1.Range('a' & j + 1) = 'Total'

sh1.Range('a' & j + 1).Offset(0, 1) = 'ALL'

sh1.Range('G' & d.Count + 2) = WorksheetFunction.Sum(Range('G2:G' & d.Count + 1))

End Sub

2、VBA之SQL语句汇总，代码如下：

Option Explicit

Sub sql_query()

Dim path As String,sq1 As String

Dim i As Integer

Dim conn As Object,rs As Object

Dim sh As Worksheet

Set sh = Sheets('总表')

Set conn = CreateObject('adodb.connection')

'创建连接对象

sh.Range('A1:G100').ClearContents

path = ThisWorkbook.FullName

If Application.Version < 12 Then

conn.Open 'provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=' & path

Else

conn.Open 'provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=' & path

End If

sq1 = 'select name ,sum(corn)as corn ,sum(millet)as millet ,sum(rapeseed) as rapeseed ,sum(other) as other, sum(corn)+sum(millet)+sum(rapeseed)+sum(other)as total from[用工费$] GROUP BY name order by name desc'

'设置SQL查询语句

Set rs = conn.Execute(sq1)

'设置结果集对象

sh.[A2].CopyFromRecordset rs

'拷贝结果集至A2单元格起始的位置

For i = 1 To rs.fields.Count

sh.Cells(1, i) = rs.fields(i - 1).name

Next i

'设置字段名

conn.Close

Set conn = Nothing

Set rs = Nothing

End Sub