Импорт из Excel в Access. Выборочно построчно - Microsoft Office Access

Zhiltsov · 02.02.2016, 18:45

Камрады!
Несколько лет назад вы меня сильно выручили с импортом из txt в access тот механизм работает до сих пор и не думает ломаться, хотя количество файлов выросло на 3 порядка. За что респект и уважуха всем Гуру форума, не оставляющих в беде таких чайников как я.
Я снова к Вам за помощью.
Ну никак не хватает времени глубоко изучить VBA т.к. нужен он раз в пятилетку, а направление моей деятельности никак не связано с программированием.
Задача у меня стоит сейчас следующая: есть папка с файлами(пример во вложении), все файлы имеют одинаковую структуру. и база данных access в которую надо импортировать данные из файлов excel. таблицы в БД соответствует листам EXCEL
необходимо из EXCEL из листа 1 в таблицу 1 БД импортировать данные из строк, в соответствии с заголовками столбцов, которые находятся между строкой содержащей текст "Раздел 1" и строкой "Итого по разделу 1" и между строкой "Раздел 2" и строкой "Итого по разделу 2", а также данные из строки "итого по отчету"
Из Листа 21 файла импортировать данные из строк находящиеся после заголовков столбцов и до строки с текстом "Итого по отчету" исключая строки с текстом "Итого по графе"
Из листа 22 строки между заголовками подразделов и итоговыми значениями подразделов по аналогии с листом 1.

Также в строки необходимо добавить информацию из имени импортируемого файла.

В примере заполнено так как должно быть.

Очень рассчитываю на вашу помощь.

Zhiltsov · 10.02.2016, 13:23

Судя по тому что никто не ответил, общее мнение на данную тему - ну ваще обнаглел все за него должны делать!

Что ж, справедливо.

Уважаемые модераторы форума. Прошу удалить тему по причине отсутствия откликов.

Aleksandr H. · 10.02.2016, 15:36

частное мнение : не обнаглел. чесно, хотелось сделать, даже тема в отдельной вкладке висит. Банально небыло времени. Если актуально, то можемо чето подумать

Zhiltsov · 10.02.2016, 15:46

Цитата:

Сообщение от Aleksandr H.

частное мнение : не обнаглел. чесно, хотелось сделать, даже тема в отдельной вкладке висит. Банально небыло времени. Если актуально, то можемо чето подумать

Александр, актуально!
Пока объемы не большие -переношу руками, дальше страшно представить что будет. Параллельно ищу среди знакомых кто бы помог, пока безрезультатно.

Aleksandr H. · 10.02.2016, 23:56

набросок для 1 листа

Код:

Sub import2accdb()
    Dim appExcel As Object
    Dim wbk As Excel.Workbook, sFile As String, f As Object
    Dim wks As Excel.Worksheet
    Dim currRow As Integer, currCol As Integer, maxRow As Double
    Dim sRazd As String
    Dim sSql As String, sVal As String, sHVal As String
    
    Dim objFSO As Object, strFileName$
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Set appExcel = CreateObject("Excel.application")
    Set f = Application.FileDialog(3)
    f.InitialFileName = CurrentProject.Path ' & "\YYYY_K_XXXXX_ZZZZZ.xls"
    f.Show
    sFile = f.SelectedItems(1)
    
    strFileName = objFSO.GetFileName(sFile)
    '========
    ' тут потянем YYYY K XXXXX ZZZZZ с имени
    '========
    Set objFSO = Nothing
    
    Set wks = wbk.Worksheets("1")
    currRow = 8
    maxRow = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    Do While currRow <= wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
        If Left(wks.Cells(currRow, 1), 6) = "Раздел" Then
            currRow = currRow + 1
            sVal = wks.Cells(currRow - 1, 1)
            sRazd = Mid(sVal, 7, Len(sVal))
            Do While Left(wks.Cells(currRow, 1), 16) <> "Итого по разделу"
                sSql = "INSERT INTO 1 (YYYY,K,XXXXX,ZZZZZ,Раздел,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) " & _
                              "VALUES ('YYYY','K','XXXXX','ZZZZZ'," & sRazd & ","
                    sVal = ""
                For currCol = 2 To 26
                    sVal = sVal & "'" & CStr(wks.Cells(currRow, currCol)) & "',"
                    If currCol = 4 Then sHVal = sVal
                Next currCol
                sSql = sSql & Left(sVal, Len(sVal) - 1) & ")"
                DoCmd.SetWarnings False
                DoCmd.RunSQL sSql
                DoCmd.SetWarnings True
                currRow = currRow + 1
            Loop
        End If
        If wks.Cells(currRow, 1) = "Итого по отчету" Then
            sSql = "INSERT INTO 1 (YYYY,K,XXXXX,ZZZZZ,Раздел,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) " & _
                              "VALUES ('YYYY','K','XXXXX','ZZZZZ','i',"
            sSql = sSql + UCase(sHVal)
                sVal = ""
                For currCol = 5 To 26
                    sVal = sVal & "'" & CStr(wks.Cells(currRow, currCol)) & "',"
                Next currCol
                sSql = sSql & Left(sVal, Len(sVal) - 1) & ")"
               
                DoCmd.SetWarnings False
                DoCmd.RunSQL sSql
                DoCmd.SetWarnings True
                currRow = currRow + 1
        End If
        currRow = currRow + 1
    Loop
    appExcel.Quit
    Set appExcel = Nothing
    Set wbk = Nothing
    Set wks = Nothing
End Sub

Zhiltsov · 11.02.2016, 09:55

Цитата:

Сообщение от Aleksandr H.

набросок для 1 листа

Код:

Sub import2accdb()
    Dim appExcel As Object
    Dim wbk As Excel.Workbook, sFile As String, f As Object
    Dim wks As Excel.Worksheet
    Dim currRow As Integer, currCol As Integer, maxRow As Double
    Dim sRazd As String
    Dim sSql As String, sVal As String, sHVal As String
    
    Dim objFSO As Object, strFileName$
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Set appExcel = CreateObject("Excel.application")
    Set f = Application.FileDialog(3)
    f.InitialFileName = CurrentProject.Path ' & "\YYYY_K_XXXXX_ZZZZZ.xls"
    f.Show
    sFile = f.SelectedItems(1)
    
    strFileName = objFSO.GetFileName(sFile)
    '========
    ' тут потянем YYYY K XXXXX ZZZZZ с имени
    '========
    Set objFSO = Nothing
    
    Set wks = wbk.Worksheets("1")
    currRow = 8
    maxRow = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    Do While currRow <= wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
        If Left(wks.Cells(currRow, 1), 6) = "Раздел" Then
            currRow = currRow + 1
            sVal = wks.Cells(currRow - 1, 1)
            sRazd = Mid(sVal, 7, Len(sVal))
            Do While Left(wks.Cells(currRow, 1), 16) <> "Итого по разделу"
                sSql = "INSERT INTO 1 (YYYY,K,XXXXX,ZZZZZ,Раздел,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) " & _
                              "VALUES ('YYYY','K','XXXXX','ZZZZZ'," & sRazd & ","
                    sVal = ""
                For currCol = 2 To 26
                    sVal = sVal & "'" & CStr(wks.Cells(currRow, currCol)) & "',"
                    If currCol = 4 Then sHVal = sVal
                Next currCol
                sSql = sSql & Left(sVal, Len(sVal) - 1) & ")"
                DoCmd.SetWarnings False
                DoCmd.RunSQL sSql
                DoCmd.SetWarnings True
                currRow = currRow + 1
            Loop
        End If
        If wks.Cells(currRow, 1) = "Итого по отчету" Then
            sSql = "INSERT INTO 1 (YYYY,K,XXXXX,ZZZZZ,Раздел,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) " & _
                              "VALUES ('YYYY','K','XXXXX','ZZZZZ','i',"
            sSql = sSql + UCase(sHVal)
                sVal = ""
                For currCol = 5 To 26
                    sVal = sVal & "'" & CStr(wks.Cells(currRow, currCol)) & "',"
                Next currCol
                sSql = sSql & Left(sVal, Len(sVal) - 1) & ")"
               
                DoCmd.SetWarnings False
                DoCmd.RunSQL sSql
                DoCmd.SetWarnings True
                currRow = currRow + 1
        End If
        currRow = currRow + 1
    Loop
    appExcel.Quit
    Set appExcel = Nothing
    Set wbk = Nothing
    Set wks = Nothing
End Sub

в месте выделенным красным ругается
Compile error:
User-defined type not defined

Aleksandr H. · 11.02.2016, 09:56

В референсах подключили Microsoft Excel?

Zhiltsov · 11.02.2016, 10:00

гугл говорит необходимо какую то библиотеку в tools-references подключить
Добавил, следующая остановка:

Цитата:

strFileName = objFSO.GetFileName(sFile)
'========
' тут потянем YYYY K XXXXX ZZZZZ с имени
'========
Set objFSO = Nothing

Set wks = wbk.Worksheets("1")
currRow = 8
maxRow = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
Do While currRow <= wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
If Left(wks.Cells(currRow, 1), 6) = "Раздел" Then

Run-time error '91': Object variable or With block variable not set

Aleksandr H. · 11.02.2016, 10:43

Писал же, что набросок

Код:

Set objFSO = Nothing
    Set wbk = appExcel.Workbooks.Open(sFile)
    Set wks = wbk.Worksheets("1")

Zhiltsov · 11.02.2016, 12:04

Александр, это замечательный набросок!!!
Я убежден, что вы сотворите из него шедевр!!!
На текущий момент замечено, что цикл останавливается только принудительно.

10.02.2016, 15:36	#3
Aleksandr H. 2 the Nation Glory Старожил Регистрация: 27.05.2014 Сообщений: 3,289	частное мнение : не обнаглел. чесно, хотелось сделать, даже тема в отдельной вкладке висит. Банально небыло времени. Если актуально, то можемо чето подумать Кто умер, но не забыт, тот бессмертен. Лао-Цзы.

11.02.2016, 09:56	#7
Aleksandr H. 2 the Nation Glory Старожил Регистрация: 27.05.2014 Сообщений: 3,289	В референсах подключили Microsoft Excel? Кто умер, но не забыт, тот бессмертен. Лао-Цзы.

11.02.2016, 10:43	#9
Aleksandr H. 2 the Nation Glory Старожил Регистрация: 27.05.2014 Сообщений: 3,289	Писал же, что набросок Код: `Set objFSO = Nothing Set wbk = appExcel.Workbooks.Open(sFile) Set wks = wbk.Worksheets("1")` Кто умер, но не забыт, тот бессмертен. Лао-Цзы.

Опции темы	Поиск в этой теме
Версия для печати Отправить по электронной почте	Поиск в этой теме: Расширенный поиск

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Импорт из Excel в Бд Access	Black_Wolf	БД в Delphi	1	27.02.2015 03:12
Импорт в Access из Excel	Proekt456	Фриланс	8	20.08.2012 11:41
Импорт-экспорт данных Excel-Access, и из Access-Excel	Людвиг	Microsoft Office Access	3	27.10.2011 14:38
Импорт из Excel в Access	mortal2010	Microsoft Office Access	1	11.02.2011 16:38
Импорт из Excel в Access	AD_min	БД в Delphi	0	28.10.2008 09:29

10.02.2016, 13:23	#2
Zhiltsov Пользователь Регистрация: 04.06.2009 Сообщений: 56	Судя по тому что никто не ответил, общее мнение на данную тему - ну ваще обнаглел все за него должны делать! Что ж, справедливо. Уважаемые модераторы форума. Прошу удалить тему по причине отсутствия откликов.

11.02.2016, 12:04	#10
Zhiltsov Пользователь Регистрация: 04.06.2009 Сообщений: 56	Александр, это замечательный набросок!!! Я убежден, что вы сотворите из него шедевр!!! На текущий момент замечено, что цикл останавливается только принудительно.