powered by simpleCommunicator - 2.0.53     © 2025 Programmizd 02
Форумы / Microsoft Access [игнор отключен] [закрыт для гостей] / VBA Выбрать лист для импорта
4 сообщений из 4, страница 1 из 1
VBA Выбрать лист для импорта
    #39496986
Ataxy
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Доброго времени суток
Есть процедура импорта экс-акс:
Код: vbnet
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.
Public Sub ImpChT()  
Dim appX As Excel.Application
Dim wB As Excel.Workbook
Dim wS As Excel.Worksheet
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim rsE As DAO.Recordset
Dim i As Long

Set appX = CreateObject("Excel.Application")
Set wB = appX.Workbooks.Open(Forms![f].[Поле6].Value)
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Таблица")
Set wS = wB.Sheets(1)
   With wS
      For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
         If Len(wS.Cells(i, "B")) > 0 Then
            With rst
            .AddNew
            On Error GoTo ErN
            ![поле] = wS.Cells(i, "A")
            ![поле] = wS.Cells(i, "B")
            ![поле] = wS.Cells(i, "C")
            On Error GoTo 0
            .Update
            End With
         End If
      Next
   End With
rst.Close: Set rst = Nothing
dbs.Close: Set rst = Nothing
wB.Close: Set wB = Nothing
appX.Quit: Set appX = Nothing

MsgBox "Импорт Завершён"

   If DCount("[Name]", "MSysObjects", "[Name] = 'Errors_Таблица'") > 0 Then
   MsgBox "Найдены ошибки в строках(см. таблицу Errors_Таблица)"
   End If
Exit Sub
ErN:
   Select Case Err.Number
   Case 3421:
      If DCount("[Name]", "MSysObjects", "[Name]='Errors_Таблица'") = 0 Then
      CurrentDb.Execute "CREATE TABLE Errors_Таблица(RowNumbers INT)"
      End If
   Set rsE = dbs.OpenRecordset("Errors_Таблица")
      With wS
         With rsE
         .AddNew
         ![RowNumbers] = wS.Cells(i, "A")
         .Update
         End With
      End With
   rsE.Close: Set rsE = Nothing
   Resume Next
   Case Else
   End Select
End Sub


Нужно сделать возможным выбрать с какого листа импорировать данные. При этом номер листа прписывается в поле (желателен именно текст бокс, не комбобокс).
Я пробовал
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
...
Dim sn As String
...
sn = CInt(Forms![Форма].[Поле].Value)
...
Set wS = wB.Sheets(sn)
...


Возникала ошибка 9 - subscript out of range в Set wS...
Ведь не нужен же массив для того, чтобы просто указать номер листа?
...
Рейтинг: 0 / 0
VBA Выбрать лист для импорта
    #39497001
AtaxyНужно сделать возможным выбрать с какого листа импорировать данные. При этом номер листа прписывается в поле (желателен именно текст бокс, не комбобокс).
Я пробовал
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
...
Dim sn As String
...
sn = CInt(Forms![Форма].[Поле].Value)
...
Set wS = wB.Sheets(sn)
...


Возникала ошибка 9 - subscript out of range в Set wS...
Ведь не нужен же массив для того, чтобы просто указать номер листа?
если хотите именно номер листа вводить, попробуйте описать вашу переменную As Integer.
...
Рейтинг: 0 / 0
VBA Выбрать лист для импорта
    #39497165
aleks222
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
1. Нафига вам OLE?
2. ODBC - гораздо быстрее, см. с Set xlsConn = New ADODB.Connection
там перебираются ВСЕ имена листов excel-я. Правда, здесь автоматический поиск нужного, но никто не запретит сложить все имена в выпадающий список.
Чуть ниже есть загрузка с листа.

Код: vbnet
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.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
Private Sub btnLoadFile_Click()

  Dim file As String, str As String, rowCnt As Integer
  Dim xlsConn As ADODB.Connection, xlsList As String, xlsRs As ADODB.Recordset
  Dim FileId As Integer, f As ADODB.Field, sName As String
  
  file = GetSetting(CurrentProject.Name, Me.Name, "btnLoadFile_LastFile")
  
  file = Trim(SelectTxtFile(file))
  
  If file = "" Then
    MsgBox "Ôàéë íå óêàçàí.", Buttons:=vbOKOnly + vbInformation, Title:=Me.Name
    Exit Sub
  End If
  
  If (InStrRev(file, ".") = 0) Or (InStrRev(file, ".") <= InStrRev(file, "\")) Then
    file = file + ".xlsx"
  End If
  
  If Dir(file) = "" Then
    MsgBox "&#212;&#224;&#233;&#235; [" + file + "] &#237;&#229; &#241;&#243;&#249;&#229;&#241;&#242;&#226;&#243;&#229;&#242;.", Buttons:=vbOKOnly + vbExclamation, Title:=Me.Name
    Exit Sub
  End If
  
  DoCmd.Hourglass True
  
  SaveSetting CurrentProject.Name, Me.Name, "btnLoadFile_LastFile", file
  
  sName = ""
  
  On Error GoTo Err_Click
  
  Set xlsConn = New ADODB.Connection
  
  With xlsConn
  
    .Provider = "MSDASQL"
    .ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
                        "DBQ=" + file + ";" & _
                        "ReadOnly=TRUE;"

    .Open
    
    xlsList = ""
    
    With .OpenSchema(adSchemaTables)
    
        While Not .EOF And (xlsList = "")
          
            str = .Fields("TABLE_NAME").value
            
            With xlsConn.Execute("SELECT * FROM [" + str + "] where 1 = 2", Options:=adCmdText)
              
              If .Fields(0).Name = "&#207;&#224;&#247;&#234;&#224;" Then xlsList = str
              
              .Close
            
            End With
            
            .MoveNext
          
        Wend
        
    End With
    
    If xlsList = "" Then
    
        MsgBox "&#203;&#232;&#241;&#242; &#241; &#228;&#224;&#237;&#237;&#251;&#236;&#232; &#226; &#244;&#224;&#233;&#235;&#229; [" + file + "] &#237;&#229; &#237;&#224;&#233;&#228;&#229;&#237;. &#203;&#232;&#241;&#242; &#232;&#249;&#229;&#242;&#241;&#255; &#239;&#238; &#231;&#224;&#227;&#238;&#235;&#238;&#226;&#234;&#243; &#241;&#242;&#238;&#235;&#225;&#246;&#224; [&#207;&#224;&#247;&#234;&#224;].", Buttons:=vbOKOnly + vbExclamation, Title:=Me.Name
    
    Else
    
        Set xlsRs = .Execute("SELECT * FROM [" + xlsList + "] where [&#205;&#238;&#236;&#229;&#240; &#228;&#238;&#234;&#243;&#236;&#229;&#237;&#242;&#224;] is not null and [&#205;&#238;&#236;&#229;&#240; &#228;&#238;&#234;&#243;&#236;&#229;&#237;&#242;&#224;] <> ''", Options:=adCmdText + adAsyncFetch)
        
        rowCnt = 0
        
        With New ADODB.Command
          
          .CommandText = "Finances.accTicketsRC_FileId"
          .CommandType = adCmdStoredProc
          .CommandTimeout = 120
          .NamedParameters = True
          .ActiveConnection = CurrentProject.Connection
          .Parameters.Append .CreateParameter("Return", adInteger, adParamReturnValue)
          .Parameters.Append .CreateParameter("@File", adVarWChar, adParamInput, 512, file)
          .Parameters.Append .CreateParameter("@Id", adInteger, adParamOutput)
          .Execute Options:=adExecuteNoRecords
          
          FileId = .Parameters("@Id")
          
        End With
        
        With New ADODB.Recordset
          .Open Source:="select top(0) * from Finances.TicketsRC_ExcelFileLines" _
                 , ActiveConnection:=CurrentProject.Connection _
                 , CursorType:=adOpenKeyset _
                 , LockType:=adLockBatchOptimistic _
                 , Options:=adCmdText
        
          While Not xlsRs.EOF
            
            .AddNew
            rowCnt = rowCnt + 1
            
            .Fields("FileId") = FileId
            
            For Each f In xlsRs.Fields
              sName = f.Name
              .Fields(sName) = f.value
            Next
            sName = ""
            
            xlsRs.MoveNext
          
          Wend
          
          .UpdateBatch
          .Close
        
        End With

        xlsRs.Close
        
        DoCmd.Hourglass False
    
        MsgBox "&#196;&#224;&#237;&#237;&#251;&#229; &#231;&#224;&#227;&#240;&#243;&#230;&#229;&#237;&#251; &#232;&#231; [" + file + "]. &#194;&#241;&#229;&#227;&#238; &#241;&#242;&#240;&#238;&#234;: " + CStr(rowCnt) + ".", Buttons:=vbOKOnly, Title:=Me.Name
        
        btnShowFiles_Click
        
    End If
    
    Set xlsRs = Nothing
  
  End With
  
  Set xlsConn = Nothing
  
  DoCmd.Hourglass False
  
Exit Sub

Err_Click:
    
    Set xlsRs = Nothing
    Set xlsConn = Nothing
    
    DoCmd.Hourglass False
    If sName <> "" Then sName = vbCrLf + " &#200;&#236;&#255; &#234;&#238;&#235;&#238;&#237;&#234;&#232;: [" + sName + "]"
    MsgBox Error_Descriptions.Translate(Err.Description) + sName, Title:=Me.Name

End Sub
...
Рейтинг: 0 / 0
VBA Выбрать лист для импорта
    #39500165
Ataxy
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Прошу прощения. Не было возможности зайти на форум и отписАться.

Непоймучка, благодарю, то что нужно.

aleks222, c ADO ещё не работал. Предложенная процедура пока кажется сложноватой. Для начала буду пробовать делать обычный импорт, а на будущее знаю где она лежит. Спасибо
...
Рейтинг: 0 / 0
4 сообщений из 4, страница 1 из 1
Форумы / Microsoft Access [игнор отключен] [закрыт для гостей] / VBA Выбрать лист для импорта
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]