Discussion :

[ridokou]

Bonjour,

j'ai une macro liée à un code SQl qui va me chercher toute ma facturation faite avec un client/fournisseur.

la macro fonctionne parfaitement à partir du moment ou ne joue la requête qu'une seule fois. Si je souhaite avoir un nouvel état, il faut que je ferme mon fichier, que je le réouvre, puis que je rejoue...

Je pense que le problème vient de la mémoire virtuelle de la requête SQl.
Y a t il un code pour vider cette mémoire (reset recordset ??)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Option Explicit
Dim cnnConn As ADODB.Connection
Dim rstRecordset As ADODB.Recordset
Dim cmdCommand As ADODB.Command
Dim sSQL As String
Const cstTimeOut As Long = 120 * 60 'en secondes
Dim DestCell As Range
 
    'Chargement de la BASE
 
Sub ChargeData_FOUR(sCritDateDeb As String, sCritDatefin As String, sCritCodeFour As String)
 
 
sSQL = sSQL + " "
 
sSQL = sSQL + " Select 'C_PF' as SOCIETE, e_contrepartieaux,t_commentaire,e_etablissement, e_journal, et_libelle, e_refinterne, sum(e_debit-e_credit) as SOLDE, e_periode"
sSQL = sSQL + " from C_pf..ecriture"
sSQL = sSQL + " left join C_Model_PF..tiers ON e_contrepartieaux = t_auxiliaire"
sSQL = sSQL + " left join C_PF..etabliss ON e_etablissement = et_etablissement"
sSQL = sSQL + " where e_general like '6%'"
sSQL = sSQL + " and e_datecomptable between '" & sCritDateDeb & "' and '" & sCritDatefin & "'"
sSQL = sSQL + " and e_journal in ('AC','ACO')"
sSQL = sSQL + " and e_contrepartieaux = '" & sCritCodeFour & "'"
sSQL = sSQL + " group by e_contrepartieaux,t_commentaire,e_etablissement, et_libelle, e_journal, e_periode, e_refinterne"
 
sSQL = sSQL + " Union all"
 
 [...]
 
    cmdCommand.CommandText = sSQL
    cmdCommand.CommandType = adCmdText
    cmdCommand.Execute
 
  'Open the recordset.
    rstRecordset.Open cmdCommand
 
  'Populer la feuille
    DestCell.Select
    DestCell.CopyFromRecordset rstRecordset
 
  'Fermer the recordset.
    rstRecordset.Close
 
End Sub
 
Sub LANCEMEN()
 
'Désactivation du recalcul automatique
       Application.Calculation = xlCalculationManual
 
'Cacher l'actualisation de l'écran
       Application.ScreenUpdating = False
 
'Active l'affichage de la barre d'état
        Application.DisplayStatusBar = True
 
'Ouverture de la connexion à la base de donnée
        Set cnnConn = New ADODB.Connection
        cnnConn.ConnectionString = "UID=tu y as cru;PWD=tu y as cru;DRIVER={SQL Server};Server=S1SRVBDD10;Database=XxXxXxXx"
        cnnConn.Open
 
'Déclaration de la commande SQL
        Set cmdCommand = New ADODB.Command
        Set cmdCommand.ActiveConnection = cnnConn
 
'Spécification du timeout
        cmdCommand.CommandTimeout = cstTimeOut
 
'Déclaration du Recordset
        Set rstRecordset = New ADODB.Recordset
        Set rstRecordset.ActiveConnection = cnnConn
 
 'Mise à jour
        Application.StatusBar = "Lancement de la requête SQL"
 
 
 'Lancement de la mise a jour
    Application.StatusBar = "Mise à jour de la requête SQL"
 
 
  '-------------------------------------------------- /-/ --------------------------------------------------------
 
        Sheets(Feuil1.Name).Select
 
        Set DestCell = Range("A2")          'Cellule de destination
        Range("A2:AG65000").Clear            'Effacer les données présentes
 
 
        Call ChargeData(Range("DATE_DEBUT").Value, Range("DATE_FIN").Value, Range("CODE").Value)
 
 
  cnnConn.Close
  Set cnnConn = Nothing
  Set rstRecordset = Nothing
  Set cmdCommand = Nothing
 
'Restore la barre d'état Excel d'origine.
Application.StatusBar = False
 
'Réactivation du raffraichissement écran
Application.ScreenUpdating = True
 
 'Enlève le sablier
Application.Cursor = xlDefault
 
 'Réactivation du recalcul automatique
Application.Calculation = xlCalculationAutomatic
 
 'Message de fin de traitement
MsgBox "Mise à jour des données terminée !", vbInformation + vbOKOnly, "Fin de traitement"
 
 
End Sub

[Godzestla]

Bonjour,

j'utilise ADo avec le code suivant en appels multiples dans mes classeurs excel sans problème.

Tu peux peut-être t'en inspirer.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Sub ReadFileI5Full(ByVal Input_File As String, ByVal Target_worksheet As String, ByVal Target_range As String)
'ReadFileI5Full : get I5 data from Lib.file(member) and insert that in Worksheet at désired range cell
'usage : ReadFileI5Full (File, Worksheet, Range)
' Input_File : can be either Lib.file
'                    or Lib.File(member)
' Target_Worksheet : Must be a valid Worksheet Name : if exists : cleared before fullfillment
'                                              if not exists : will be created
' Target_Range     : Must be a valid cell name : Example "A1"
 
    On Error GoTo ErrorHandler
 
    Dim cn          As New ADODB.Connection
    Dim rs          As New ADODB.Recordset
    Dim sConn       As String
    Dim SqlString   As String
    Dim FileName    As String
    Dim DSN_Name As String
    Dim ws          As String 'Results Storing Worksheet name
    Dim Rg          As String 'results Cells top left
    Dim cellule     As Range
    Dim CompA       As Integer
    Dim idx         As Long
    Dim sheet_found As Boolean
    Dim ActShName   As String
    Dim Rec_nbr     As Long   'Record Set record Count
 
 
 
 
 
    sConn = "provider=IBMDA400;Data source=xxx.xxx.xxx.xxx;USER ID=USER;PASSWORD=PSW"
    FileName = Trim(Input_File)
    ws = Trim(Target_worksheet)
    Rg = Trim(Target_range)
 
    'check target Worsksheet exists and if not build
    sheet_found = False
    For idx = 1 To Sheets.Count
        If Sheets(idx).Name = ws Then
            Application.DisplayAlerts = False
            Sheets(idx).Cells.Clear
            Application.DisplayAlerts = True
            sheet_found = True
            Exit For
        End If
    Next idx
    'Build Ws
    If Not sheet_found Then
        ActShName = ActiveSheet.Name
        Sheets.Add
        ActiveSheet.Name = ws
        Sheets(ActShName).Activate
    End If
 
    'Open Connection
    cn.ConnectionString = sConn
    cn.Open
    SqlString = "SELECT * FROM " & FileName & ""
 
    'open record Set
    rs.Open SqlString, cn
    Rec_nbr = rs.RecordCount
 
 
 
    'Paste Fields names in line 1
    Set cellule = Worksheets(ws).Range(Rg)
    For CompA = 0 To rs.Fields.Count - 1
        cellule.Offset(0, CompA).Value = rs.Fields(CompA).Name
    Next CompA
    'Paste results line above names
    Worksheets(ws).Range(Rg).Offset(1, 0).CopyFromRecordset rs
 
    rs.Close
    cn.Close
    Set cn = Nothing
    Set rs = Nothing
    'MsgBox Rec_nbr & " records imported from I5"
 
    Exit Sub
ErrorHandler:
    ' clean up
    If Not cn Is Nothing Then
        If cn.State = adstateopen Then cn.Close
    End If
    Set cn = Nothing
    If Not rs Is Nothing Then
        If rs.State = adstateopen Then rs.Close
    End If
    If Err <> 0 Then
      MsgBox Err.Source & "-->" & Err.Description, , "Error"
    End If
 
End Sub

Bonne chance.