|
Цикл For Each выдает ошибку Application-defined or object-defined error
#38710816
Ссылка:
Ссылка на сообщение:
Ссылка с названием темы:
|
|
|
|
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.
Sub OpenDB()
'===
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
'===
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim a As Workbook
Dim k As Long, k1 As Long, i As Long, mv As String, pp As Date
Set a = ThisWorkbook
k = a.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row 'Íîìåð ïîñëåäíåé çàïîëíåííîé ñòðîêè
a.Sheets(1).Range("D6:D" & CStr(k) & "").ClearContents 'Î÷èñòêà ñòîëáöà îò çíà÷åíèé
a.Sheets(1).Range("E6:E" & CStr(k) & "").ClearContents
'===
Set conn = New ADODB.Connection 'Ñîçäàåì íîâîå ïîäêëþ÷åíèå
conn = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=D:\Âèíòàæè.accdb;Uid=Admin;Pwd=;"
conn.Open
'===
'If conn.State = 1 Then
'MsgBox "Åñòü êîíòàêò!"
'Else
'MsgBox "Áåäà :("
'End If
'===
k1 = a.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row
For i = 6 To k1
mv = a.Sheets(1).Cells(i, 2)
pp = a.Sheets(1).Cells(i, 3)
'MsgBox nn
Set rst = New ADODB.Recordset 'Ñîçäàåì îáúåêò Recordset äëÿ çàïèñè SQL-êîäà
rst.Open ("SELECT SUM(Ïîðòôåëü.Ðàçìåð_êðåäèòà) From Ïîðòôåëü WHERE Ïîðòôåëü.Ìåñÿö_âûäà÷è = '" & CStr(mv) & "' AND Ïîðòôåëü.Ïîðòôåëü = #" & Format(pp, "mm-dd-yyyy") & "#"), conn 'Çàïèñûâàåì êîä â Recordset
a.Sheets(1).Cells(i, 4).CopyFromRecordset rst 'Êîïèðóåì èç Recordset
Set rst = New ADODB.Recordset 'Ñîçäàåì îáúåêò Recordset äëÿ çàïèñè SQL-êîäà
rst.Open ("SELECT COUNT(Ïîðòôåëü.Êëèåíò) From Ïîðòôåëü WHERE Ïîðòôåëü.Ìåñÿö_âûäà÷è = '" & CStr(mv) & "' AND Ïîðòôåëü.Ïîðòôåëü = #" & Format(pp, "mm-dd-yyyy") & "#"), conn 'Çàïèñûâàåì êîä â Recordset
a.Sheets(1).Cells(i, 5).CopyFromRecordset rst 'Êîïèðóåì èç Recordset
Next i
'===
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
'===
End Sub
Sub VintageAnalis()
'===
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
'===
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim a As Workbook
Dim k As Long, k1 As Long, i As Range, mv As String, pp As String
Set a = ThisWorkbook
k = a.Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row 'Íîìåð ïîñëåäíåé çàïîëíåííîé ñòðîêè
k1 = a.Sheets(2).UsedRange.Columns.Count 'Íîìåð ïîñëåäíåãî ñòîëáöà, åñëè íåò ïóñòûõ ÿ÷ååê â ñòðîêå 2
a.Sheets(2).Range("B3:DD333").ClearContents
'===
Set conn = New ADODB.Connection 'Ñîçäàåì íîâîå ïîäêëþ÷åíèå
conn = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=D:\Âèíòàæè.accdb;Uid=Admin;Pwd=;"
conn.Open
'===
'If conn.State = 1 Then
'MsgBox "Åñòü êîíòàêò!"
'Else
'MsgBox "Áåäà :("
'End If
'===
For Each i In a.Sheets(2).Range(a.Sheets(2).Cells(3, 2), a.Sheets(2).Cells(k, k1))
mv = a.Sheets(2).Cells(i.Row, 1)
pp = a.Sheets(2).Cells(2, i.Column)
'MsgBox pp
Set rst = New ADODB.Recordset 'Ñîçäàåì îáúåêò Recordset äëÿ çàïèñè SQL-êîäà
rst.Open ("SELECT SUM(Ïîðòôåëü.Ðàçìåð_êðåäèòà) From Ïîðòôåëü WHERE Ïîðòôåëü.Ìåñÿö_âûäà÷è = '" & CStr(mv) & "' AND Ïîðòôåëü.Ìåñÿöû_ïîñëå_âûäà÷è = '" & CStr(pp) & "' AND Ïîðòôåëü.Äåôîëò = 'Äà'"), conn 'Çàïèñûâàåì êîä â Recordset
Cells(i.Row, i.Column).CopyFromRecordset rst 'Êîïèðóåì èç Recordset
Next i
'===
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
'===
End Sub
2 Subа находятся в 1 модуле. Каждый из них привязан к фигуре, которая находится на 1 листе. |
|
|
