Temat: Pomoc w napisaniu Makra lub formuł
Pani Ilono,
Musi Pani dodać referencje do odpowiednich bibliotek.
W edytorze, w którym wkleiła Pani mój kod, bardzo proszę wybrać menu "Tools">>>"References" i na długiej liście dostępnych bibliotek proszę poszukać i zaznaczyć:
1) Microsoft ActiveX Data Objects X.X Library
2) Microsoft ActiveX Data Objects Recordset X.X Library
gdzie X.X to numer najwyższej dostępnej u Pani wersji.
To powinno załatwić problem.
Dodatkowo, tak jak obiecałem przedstawiam poprawiony kod.
Sub prepareToInvoicingV2()
Dim sTempFilePath As String
Dim sConnection As String
Dim oRS As Object
Dim oRS_writable As Object
Dim oConn As Object
Dim sqlQuery As String
Dim sOpisFV As String, iProdukty As Integer, sProdukty As String
1 On Error GoTo ErrorHandler
2 sTempFilePath = ThisWorkbook.Path
3 sTempFilePath = sTempFilePath & "\" & "TempFile_" & Format(Time(), "hhmmss") & ".xls"
'create workbook copy
4 ThisWorkbook.SaveCopyAs sTempFilePath
5 If Application.Version >= 12 Then
'use ACE provider
6 sConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & _
sTempFilePath & ";Extended Properties=""Excel 12.0;HDR=YES;"""
7 Else
'use JET provider
8 sConnection = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
sTempFilePath & ";Extended Properties=""Excel 8.0;HDR=YES;"""
9 End If
10 Set oRS = CreateObject("ADODB.Recordset")
11 Set oRS_writable = CreateObject("ADODB.Recordset")
12 Set oConn = CreateObject("ADODB.Connection")
'open ADO connection
13 oConn.Open sConnection
'base SQL QUERY
14 sqlQuery = "SELECT [Nr klienta (AM)] AS [Nr klienta (AM)], " & _
"' ' AS [OpisNaFV], " & _
"COUNT([NumerProduktu]) AS [ile produktów], " & _
"SUM(IIF([NazwaPakietu]='PakietA', 1, 0)) AS [ile pakietówA], " & _
"SUM(IIF([NazwaPakietu]='PakietB', 1, 0)) AS [ile pakietówB], " & _
"SUM(IIF([NazwaPakietu]='PakietC', 1, 0)) AS [ile pakietówC], " & _
"SUM([Kwota netto]) AS [KwotaFaktury] " & _
"FROM [Step1$] GROUP BY [Nr klienta (AM)] ORDER BY [Nr klienta (AM)]"
'open recordset
15 oRS.Open sqlQuery, oConn, 3, 1
'clone base recordset structure
16 Call cloneRecordsetStructure(oRS, oRS_writable)
'copy base recordset values
17 oRS_writable.CursorLocation = adUseClient
18 oRS_writable.Open
'loop trough base recordset to copy its values
19 Do Until oRS.EOF
'add new record to writable recordset
20 oRS_writable.AddNew
'copy each field-value pair from base recordset to writable one
21 For Each f In oRS.Fields 'f - ADODB.Field
22 oRS_writable(f.Name).Value = f.Value
23 Next f
24 sOpisFV = printf("%s%s%s", _
getFVdetails(oRS.Fields("Nr klienta (AM)"), "PakietA", oConn), _
getFVdetails(oRS.Fields("Nr klienta (AM)"), "PakietB", oConn), _
getFVdetails(oRS.Fields("Nr klienta (AM)"), "PakietC", oConn))
'add proper value to OpisNaFV field
25 oRS_writable("OpisNaFV").Value = Left(sOpisFV, Len(sOpisFV) - 1)
26 oRS_writable.Update
27 oRS.MoveNext
28 Loop
29 oRS_writable.MoveFirst
'create worksheet for results
30 ThisWorkbook.Worksheets.Add().Name = "result"
'create headers
31 For i = 0 To oRS_writable.Fields.COUNT - 1
32 ThisWorkbook.Sheets("result").Cells(1, i + 1).Value = oRS_writable.Fields(i).Name
33 Next i
'pasete values
34 ThisWorkbook.Sheets("result").Range("A2").CopyFromRecordset oRS_writable
ErrorExit:
35 If oRS.State <> 0 Then oRS.Close
36 If oRS_writable.State <> 0 Then oRS_writable.Close
37 oConn.Close
38 Set oRS = Nothing
39 Set oConn = Nothing
40 Kill sTempFilePath
ErrorHandler:
41 If Err.Number <> 0 Then
42 MsgBox "Wystąpił błąd nr " & Err.Number & " (" & Err.Description & ")." & _
vbCr & vbCr & "Linia kodu nr " & Erl(), vbCritical, "BŁĄD!"
43 Resume ErrorExit
44 End If
End Sub
Private Function cloneRecordsetStructure(sourceRs As ADODB.Recordset, ByRef destRs As ADODB.Recordset)
1 For Each f In sourceRs.Fields 'f - ADODB.Field
2 destRs.Fields.Append f.Name, f.Type, f.DefinedSize, f.Attributes And &H20
3 With destRs(f.Name)
4 .Precision = f.Precision
5 .NumericScale = f.NumericScale
6 End With
7 Next f
End Function
Private Function getFVdetails(klientId As Integer, pakietName As String, ByRef oConn As ADODB.Connection) As String
Dim oCommand As Object
Dim oRS As Object
Dim sProductsList As String
Dim usluga As String, kwota As String
Dim retVal As String
1 Set oCommand = New ADODB.Command
2 Set oRS = New ADODB.Recordset
3 With oRS
4 .CursorLocation = adUseClient 'adUseClient
5 End With
6 On Error GoTo ErrorHandler
7 With oCommand
8 .ActiveConnection = oConn
9 .CommandText = "SELECT [Usluga], [NumerProduktu], [NazwaPakietu], [Kwota netto] FROM [Step1$] WHERE [Nr klienta (AM)]=@klientId AND [NazwaPakietu]=@pakietName ORDER BY [Usluga]"
10 .CommandType = adCmdText
11 .Prepared = True
12 .Parameters.Append .CreateParameter("Nr klienta (AM)", adInteger, adParamInput, , klientId)
13 .Parameters.Append .CreateParameter("NazwaPakietu", adVarChar, adParamInput, 25, pakietName)
14 End With
15 oRS.Open oCommand, , 3, 1
16 If oRS.RecordCount > 0 Then
17 Do Until oRS.EOF
18 usluga = oRS.Fields("Usluga")
19 kwota = Format(oRS.Fields("Kwota netto"), "##zł")
20 sProductsList = printf("%s%s,", sProductsList, oRS.Fields("NumerProduktu"))
21 oRS.MoveNext
22 Loop
23 retVal = printf("%s %s:%s x %s (%s)%s", usluga, pakietName, kwota, oRS.RecordCount, Left(sProductsList, Len(sProductsList) - 1), Chr(10))
24 End If
25 getFVdetails = retVal
ErrorExit:
26 oRS.Close
27 Set oCommand = Nothing
28 Set oRS = Nothing
ErrorHandler:
29 If Err.Number <> 0 Then
30 MsgBox "Wystąpił błąd nr " & Err.Number & " (" & Err.Description & ")." & _
vbCr & vbCr & "Linia kodu nr " & Erl(), vbCritical, "BŁĄD!"
31 Resume ErrorExit
32 End If
End Function
Private Function printf(s As String, ParamArray args())
Dim a As Variant
1 For Each a In args
2 s = Replace(s, "%s", a, 1, 1)
3 Next
4 printf = s
End Function
Ten post został edytowany przez Autora dnia 07.01.14 o godzinie 22:32
пропозиції роботи
