Эта функция "распрямит" перекрестный запрос в строчную таблицу с тремя полями
Эта функция "распрямит" перекрестный запрос в строчную таблицу с тремя полями Для работы необходима ссылка на MS DAO (только для перекрестных запросов с группировкой по одному полю)
Sub TransformToRows(tIN_TableName, tOUT_TableName, tDataType As DataTypeEnum) 'для MSA 97 необходимо заменить tDataType As DataTypeEnum на tDataType As Integer Dim MyRstIn As Recordset Dim MyRstOut As Recordset Dim tFields(2) Dim tData Dim j As Long, I As Long Dim TableHeight, TableWidth
'открыть исходную Set MyRstIn = CurrentDb.OpenRecordset(tIN_TableName, dbOpenDynaset) 'открыть выходную Set MyRstOut = CurrentDb.OpenRecordset(tOUT_TableName, dbOpenDynaset)
TableWidth = MyRstIn.Fields.Count - 1
ReDim tData(TableWidth)
With MyRstIn .MoveLast .MoveFirst TableHeight = .RecordCount End With
'получение данных в таблицу For I = 1 To TableHeight ' Данные из первого столбца tData(0) = MyRstIn.Fields(0) ' получить данные For j = 1 To TableWidth tData(1) = MyRstIn.Fields(j).Name ' Имя столбца J tData(2) = MyRstIn.Fields(j) ' Данные столбца J ' записать данные With MyRstOut .AddNew 'Заполнение полей значениями .Fields(tFields(0)) = tData(0) .Fields(tFields(1)) = tData(1) .Fields(tFields(2)) = tData(2) .Update End With
Next j
MyRstIn.MoveNext Next I
MyRstIn.Close Set MyRstIn = Nothing MyRstOut.Close Set MyRstOut = Nothing
End Sub Sub MakeTable(tTableName, tFields, tDataType) 'создать таблицу по шаблону пользователя Dim MyTable As TableDef Dim MyField As Field Dim MyRst As Recordset Dim MyIdx As Index Dim j As Integer
On Error Resume Next CurrentDb.TableDefs.Delete tTableName
Set MyTable = CurrentDb.CreateTableDef(tTableName)
'Первое заголовочное поле MyTable.Fields.Append MyTable.CreateField(tFields(0), dbText) 'Второе заголовочное поле MyTable.Fields.Append MyTable.CreateField(tFields(1), dbText)
'Поля данных For j = LBound(tFields) + 2 To UBound(tFields) MyTable.Fields.Append MyTable.CreateField(tFields(j), tDataType) Next
CurrentDb.TableDefs.Append MyTable Set MyTable = Nothing