Выгрузка в Excel

@Sima42 · Регистрация: 06.08.2011

Студворк — интернет-сервис помощи студентам

Здравствуйте!
Возникла проблема!
Нужно из MS Access перенести в Excel. Вроде банально, но нужно во время переноса изменять данные. Есть поле "Работа" это список значений "1 - Работает";"2 - Безработный";"3 - И т.д" а нужно что бы в Excelе было "1", "2" или "3".

@Eugene-LS · 17.12.2017, 14:48

Сообщение от Sima42

а нужно что бы в Excelе было "1", "2" или "3".

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Private Sub Кнопка2_Click()
 
Dim strsql, temp1, rst As DAO.Recordset
Dim r%, c%
Dim oExcel As Object
   Dim oBook As Object
   Dim oSheet As Object
 
   'Start a new workbook in Excel
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add
 
 
   'Add data to cells of the first worksheet in the new workbook
   Set oSheet = oBook.Worksheets(1)
   oSheet.Range("A1").Value = "Код"
   oSheet.Range("B1").Value = "Имя"
   oSheet.Range("C1").Value = "Кол-во"
   oSheet.Range("D1").Value = "Дата"
   oSheet.Range("F1").Value = "Адрес"
   oSheet.Range("G1").Value = "Семейное положение"
 
   'Save the Workbook and Quit Excel
   
  Set rst = CurrentDb.OpenRecordset("Таблица1", dbOpenSnapshot)  'Только просмотр
 
    r = 1
    With rst
        Do Until .EOF = True 'Цикл до конца таблицы
            '...операции с записью
            'Тут так: cells(lRowNo, lColumnNo)
            r = r + 1
            For c = 1 To 6
                oExcel.cells(r, c) = rst.Fields(c - 1).Value
            Next c
            .MoveNext
        Loop
    End With
   
 
   oBook.SaveAs CurrentProject.Path & "\Book1.xls"
   oExcel.Quit
   
 
    MsgBox "Готово"
    
On Error Resume Next
    rst.Close
    Set rst = Nothing
 
End Sub

@Sima42 · 17.12.2017, 14:57 **[ТС]**

Большое человеческое СПАСИБО!!!!!!!!!!! Очень выручил.

@Eugene-LS · 17.12.2017, 15:01

Sima42, Я поторопился и не туда посмотрел

Вот правильный вариант:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Private Sub Кнопка2_Click()
 
Dim strsql, temp1, rst As DAO.Recordset
Dim r%, c%
Dim oExcel As Object
   Dim oBook As Object
   Dim oSheet As Object
 
   'Start a new workbook in Excel
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add
 
 
   'Add data to cells of the first worksheet in the new workbook
   Set oSheet = oBook.Worksheets(1)
   oSheet.Range("A1").Value = "Код"
   oSheet.Range("B1").Value = "Имя"
   oSheet.Range("C1").Value = "Кол-во"
   oSheet.Range("D1").Value = "Дата"
   oSheet.Range("E1").Value = "Работа"
   oSheet.Range("F1").Value = "Адрес"
   oSheet.Range("G1").Value = "Семейное положение"
 
   'Save the Workbook and Quit Excel
   
  Set rst = CurrentDb.OpenRecordset("Таблица1", dbOpenSnapshot)  'Только просмотр
 
    r = 1
    With rst
        Do Until .EOF = True 'Цикл до конца таблицы
            '...операции с записью
            'Тут так: cells(lRowNo, lColumnNo)
            r = r + 1
            For c = 1 To 7
                Select Case c
                    Case 5, 7
                        If IsNull(rst.Fields(c - 1).Value) = False Then
                            oExcel.cells(r, c) = Mid(rst.Fields(c - 1).Value, 1, 1)
                        End If
                    Case Else
                        oExcel.cells(r, c) = rst.Fields(c - 1).Value
                End Select
            Next c
            .MoveNext
        Loop
    End With
   
 
   oBook.SaveAs CurrentProject.Path & "\Book1.xls"
   oExcel.Quit
   
 
    MsgBox "Готово"
    
On Error Resume Next
    rst.Close
    Set rst = Nothing
 
 
End Sub

@Sima42 · 17.12.2017, 15:03 **[ТС]**

Я уже это дописал

mobile · 17.12.2017, 15:10

Можно немного попроще, используя CopyFromRecordset и, заменяя с помощью Val, текстовые значения на числа

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Sub Кнопка2_Click()
 
Dim strsql, temp1, i, rst As DAO.Recordset
Dim oExcel As Object, oBook As Object, oSheet As Object
   'Start a new workbook in Excel
    Set oExcel = CreateObject("Excel.Application")
    Set oBook = oExcel.Workbooks.Add
    
    strsql = "select Код, Имя, [Кол-во], [Дата], " _
    & "val(Таблица1.Работа) as Работа, Адрес, " _
    & "val(Таблица1.[Семейное положение]) as [Семейное положение] " _
    & "from Таблица1"
    Set rst = CurrentDb.OpenRecordset(strsql)
    For i = 0 To rst.Fields.Count - 1
        oExcel.cells(1, i + 1) = rst.Fields(i).Name
    Next
    oExcel.cells(2, 1).copyfromrecordset rst
    'Save the Workbook and Quit Excel
    oBook.SaveAs "D:\Book1.xls"
    oExcel.Quit
    MsgBox "Готово"
End Sub

@Sima42 · 17.12.2017, 15:22 **[ТС]**

Как вы думаете какой метод будет более уместный? 1 таблица примерно 250 полей. Много полей со списками значений и их и нужно будет обрабатывать (по принципу что сверху).

@Eugene-LS · 17.12.2017, 15:53

Сообщение от Sima42

Как вы думаете какой метод будет более уместный?

Оба работают ...
Вариант от mobile, короче и более правильный, что-ли....

Ещё к обоим вариантам можно прикрутить такой код

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
'Выставляем ширину столбцов
    For c = 1 To 7
        Select Case c
            Case 1
                oExcel.Columns(c).ColumnWidth = 7
            Case 3, 4, 5
                oExcel.Columns(c).ColumnWidth = 12
            Case Else
                'oExcel.Columns(c).AutoFit
                oExcel.Columns(c).ColumnWidth = 24
        End Select
    Next c
    
'Задаём путь приложения
    intBoockNo = intBoockNo + 1
    i = CInt(Mid(Application.Version, 1, 2)) 'Версия MS Access
    If i > 11 Then 'Версия MS Access 2007 и выше (не 2003)
        s = CurrentProject.Path & "\Book" & Format(intBoockNo, "000") & ".xlsx"
    Else
        s = CurrentProject.Path & "\Book" & Format(intBoockNo, "000") & ".xls"
    End If
    
'Сохраняем в папке приложения
 
   oBook.SaveAs s
   oExcel.Visible = True
   'oExcel.Quit
   
 
    MsgBox "Готово", vbInformation

Причём: intBoockNo (номер файла) объявляем на уровне модуля

Visual Basic
1
Private intBoockNo As Integer

@Sima42 · 17.12.2017, 16:37 **[ТС]**

Спасибо вам всем огромное за ответы!

mobile · 17.12.2017, 17:04

Сообщение от Sima42

таблица примерно 250 полей. Много полей со списками значений и их и нужно будет обрабатывать (по принципу что сверху).

При таком количестве полей вручную их описывать и модифицировать запаришься. Предлагаю вариант с автоматическим построением sql запроса с помощью функции makeSql

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Private Sub Кнопка2_Click()
 
Dim strsql, temp1, i, rst As DAO.Recordset
Dim oExcel As Object, oBook As Object, oSheet As Object
   'Start a new workbook in Excel
    Set oExcel = CreateObject("Excel.Application")
    Set oBook = oExcel.Workbooks.Add
    
    strsql = makeSql("Таблица1")
    Set rst = CurrentDb.OpenRecordset(strsql)
    For i = 0 To rst.Fields.Count - 1
        oExcel.cells(1, i + 1) = rst.Fields(i).Name
    Next
    oExcel.cells(2, 1).copyfromrecordset rst
    'Save the Workbook and Quit Excel
    oBook.SaveAs "D:\Book1.xls"
    oExcel.Quit
    MsgBox "Готово"
End Sub
 
Function makeSql(nameTbl)
'nameTbl - имя таблицы
    Dim tdf As TableDef, db As DAO.Database, fld As Field
    Dim s, i, k
    Set db = CurrentDb
    Set tdf = db.TableDefs(nameTbl)
    For Each fld In tdf.Fields
        k = fld.Name
        On Error Resume Next
        i = fld.Properties("rowsource")
        If Err = 0 Then
            s = s & ",Val([" & nameTbl & "].[" & k & "]) as [" & k & "]"
        Else
            s = s & ",[" & k & "]"
        End If
        Err.Clear
    Next
    s = "select " & Mid(s, 2) & " from " & nameTbl
    makeSql = s
End Function

@Eugene-LS · 17.12.2017, 17:44

Я тут себе, примерчик соорудил по данной теме (на память).
Если интересно, то вот:

@Sima42 · 18.12.2017, 08:58 **[ТС]**

Еще бы добавить по связанным таблицам, и вообще универсальная база

Добавлено через 2 часа 14 минут
А как быть если 2 таблицы связанные 1 к 1 то как быть тогда?

Добавлено через 10 часов 11 минут
Все верно! Чего боялся то и получилось. Пришел на работу. Открыл базу а там 2 таблицы связанные 1 к 1.

mobile · 18.12.2017, 09:06

Сообщение от Sima42

Еще бы добавить по связанным таблицам, и вообще универсальная база

А как быть если 2 таблицы связанные 1 к 1 то как быть тогда?

Это запросами. Но надо иметь в виду, что в запросах, как и в таблицах, не может быть больше 255 полей.

Смотрите вложение. Скопируйте Form1 к себе в БД. В форме есть актуальный список таблиц/запросов. Выбираете нужный и жмете кнопку Послать...в Excel. Можно выбрать путь и имя книги в самом нижнем поле.
На всякий случай вверху формы есть кнопка Обновить список таблиц/запросов. Если форма открыта и Вы сделали новый запрос или таблицу, которых еще нет в списке, то кнопка поместит их в список.

@Sima42 · 18.12.2017, 09:45 **[ТС]**

Сообщение от mobile

Это запросами. Но надо иметь в виду, что в запросах, как и в таблицах, не может быть больше 255 полей.

А там явно будет больше. Я тут первый пример доделал под 2 таблицы. Не совсем будет быстро работать. Но там полей много а строк максимум 50. Только вопрос почему когда екселевский файл открываешь, ещё книга открывается.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Private Sub Кнопка1_Click()
 
Dim strsql, temp1, rst As DAO.Recordset
Dim r%, c%, r1%
Dim oExcel As Object
   Dim oBook As Object
   Dim oSheet As Object
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add
 
   Set oSheet = oBook.Worksheets(1)
   oSheet.Range("A1").Value = "Код"
   oSheet.Range("B1").Value = "Имя"
   oSheet.Range("C1").Value = "Кол-во"
   oSheet.Range("D1").Value = "Дата"
   oSheet.Range("E1").Value = "Работа"
   oSheet.Range("F1").Value = "Адрес"
   oSheet.Range("G1").Value = "Семейное положение"
 Set rst = CurrentDb.OpenRecordset("Таблица1", dbOpenSnapshot)  'Только просмотр
    r = 1
    With rst
        Do Until rst.EOF = True
            r = r + 1
            For c = 1 To 7
                Select Case c
                    Case 5, 7
                        If IsNull(rst.Fields(c - 1).Value) = False Then
                            oExcel.cells(r, c) = Mid(rst.Fields(c - 1).Value, 1, 1)
                        End If
                    Case Else
                        oExcel.cells(r, c) = rst.Fields(c - 1).Value
                    End Select
            Next c
            rst.MoveNext
            Set rst1 = CurrentDb.OpenRecordset("Таблица2", dbOpenSnapshot)
            With rst1
                Do Until rst1.EOF = True
                    If oExcel.cells(r, 1) = rst1.Fields(0) Then
                       For c = 1 To 7
                            Select Case c
                                Case 2, 3
                                    If IsNull(rst1.Fields(c - 1).Value) = False Then
                                        oExcel.cells(r, c + 7) = Mid(rst1.Fields(c - 1).Value, 1, 1)
                                    End If
                                Case Else
                                    oExcel.cells(r, c + 7) = rst1.Fields(c - 1).Value
                            End Select
                        Next c
                    End If
                rst1.MoveNext
                Loop
            End With
        Loop
    End With
   oBook.SaveAs CurrentProject.Path & "\Book1.xls"
   oExcel.Quit
   
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    
    On Error Resume Next
    rst1.Close
    Set rst1 = Nothing
    
    MsgBox "Готово"
 
 
End Sub

Новые блоги и статьи Все статьи Все блоги /
Новый ноутбук volvo 07.12.2025 Всем привет. По скидке в "черную пятницу" взял себе новый ноутбук Lenovo ThinkBook 16 G7 на Амазоне: Ryzen 5 7533HS 64 Gb DDR5 1Tb NVMe 16" Full HD Display Win11 Pro	Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .	От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .	Поиск "дружественных имён" СОМ портов Argus19 22.11.2025 Поиск "дружественных имён" СОМ портов На странице: https:/ / norseev. ru/ 2018/ 01/ 04/ comportlist_windows/ нашёл схожую тему. Там приведён код на С++, который показывает только имена СОМ портов, типа,. . .	Сколько Государство потратило денег на меня, обеспечивая инсулином. Programma_Boinc 20.11.2025 Сколько Государство потратило денег на меня, обеспечивая инсулином. Вот решила сделать интересный приблизительный подсчет, сколько государство потратило на меня денег на покупку инсулинов. . . .
Ломающие изменения в C#.NStar Alpha Etyuhibosecyu 20.11.2025 Уже можно не только тестировать, но и пользоваться C#. NStar - писать оконные приложения, содержащие надписи, кнопки, текстовые поля и даже изображения, например, моя игра "Три в ряд" написана на этом. . .	Мысли в слух kumehtar 18.11.2025 Кстати, совсем недавно имел разговор на тему медитаций с людьми. И обнаружил, что они вообще не понимают что такое медитация и зачем она нужна. Самые базовые вещи. Для них это - когда просто люди. . .	Создание Single Page Application на фреймах krapotkin 16.11.2025 Статья исключительно для начинающих. Подходы оригинальностью не блещут. В век Веб все очень привыкли к дизайну Single-Page-Application . Быстренько разберем подход "на фреймах". Мы делаем одну. . .	Фото: Daniel Greenwood kumehtar 13.11.2025	Расскажи мне о Мире, бродяга kumehtar 12.11.2025 — Расскажи мне о Мире, бродяга, Ты же видел моря и метели. Как сменялись короны и стяги, Как эпохи стрелою летели. - Этот мир — это крылья и горы, Снег и пламя, любовь и тревоги, И бескрайние. . .

@Sima42 0 / 0 / 0 Регистрация: 06.08.2011 Сообщений: 18
	17.12.2017, 14:57 [ТС]
	Большое человеческое СПАСИБО!!!!!!!!!!! Очень выручил. 0

@Sima42 0 / 0 / 0 Регистрация: 06.08.2011 Сообщений: 18
	17.12.2017, 15:03 [ТС]
	Я уже это дописал 0

@Sima42 0 / 0 / 0 Регистрация: 06.08.2011 Сообщений: 18
	17.12.2017, 15:22 [ТС]
	Как вы думаете какой метод будет более уместный? 1 таблица примерно 250 полей. Много полей со списками значений и их и нужно будет обрабатывать (по принципу что сверху). 0

@Sima42 0 / 0 / 0 Регистрация: 06.08.2011 Сообщений: 18
	17.12.2017, 16:37 [ТС]
	Спасибо вам всем огромное за ответы! 0

@Sima42 0 / 0 / 0 Регистрация: 06.08.2011 Сообщений: 18
	18.12.2017, 08:58 [ТС]
	Еще бы добавить по связанным таблицам, и вообще универсальная база Добавлено через 2 часа 14 минут А как быть если 2 таблицы связанные 1 к 1 то как быть тогда? Добавлено через 10 часов 11 минут Все верно! Чего боялся то и получилось. Пришел на работу. Открыл базу а там 2 таблицы связанные 1 к 1. 0

Выгрузка в Excel

Решение