假如源表为:表1(组别,姓名,编号,电话),目标表为:tmpTbl(id,组别,姓名1,编号1,电话1,姓名2,编号2,电话2,...),则:
Public Sub toCross()
On Error Resume Next
'引用ado
Dim rs As New ADODB.Recordset, Rec As New ADODB.Recordset, sql, i, zb As String, zbNum As Long
CurrentProject.Connection.Execute "drop table tmpTbl" '删除已存在的交叉表
sql = "create table tmpTbl (id AUTOINCREMENT,组别 varchar(50))"
CurrentProject.Connection.Execute sql '创建目标表及基础字段
Application.RefreshDatabaseWindow '刷新数据库导航窗格
Err.Clear
On Error GoTo er
sql = "SELECT Max(tmp.组别之计算) AS 数量 FROM (SELECT 表1.组别, Count(表1.组别) AS 组别之计算 FROM 表1 GROUP BY 表1.组别) AS tmp"
rs.Open sql, CurrentProject.Connection, adOpenStatic, adLockReadOnly '获得组别中的最多记录数
For i = 1 To rs.Fields(0) '添加交叉表的重复性字段
sql = "alter table tmptbl add COLUMN 姓名" & i & " varchar(50)"
CurrentProject.Connection.Execute sql
sql = "alter table tmptbl add COLUMN 编号" & i & " varchar(50)"
CurrentProject.Connection.Execute sql
sql = "alter table tmptbl add COLUMN 电话" & i & " varchar(50)"
CurrentProject.Connection.Execute sql
Next i
rs.Close
Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM 表1 order by 组别,编号", CurrentProject.Connection, adOpenStatic, adLockReadOnly
Rec.Open "select * from tmpTbl", CurrentProject.Connection, adOpenStatic, adLockPessimistic
For i = 1 To rs.RecordCount
If rs!组别 <> zb Then '只有更换组别时,目标表才换行
If Rec.RecordCount > 0 Then Rec.Update '保存之前未保存的记录,0记录数更新时会出错
Rec.AddNew '换行
Rec!组别 = rs!组别
zbNum = 1 '调整交叉表的重复性字段序号
Else
zbNum = zbNum + 1 '记录交叉表的重复性字段序号
End If
Rec("姓名" & zbNum) = rs!姓名
Rec("编号" & zbNum) = rs!编号
Rec("电话" & zbNum) = rs!电话
zb = rs!组别
rs.MoveNext
Next i
Rec.Update '保存最后一条记录,防止数据丢失
rs.Close: Rec.Close: Set rs = Nothing: Set Rec = Nothing '打扫战场
Exit Sub
er:
MsgBox "发生错误:" & Err.Number & "," & Err.Description
End Sub
