XL 2013 remplir une listview

[harissa555]

bonjour,
J'ai reçu un vieux fichier excel que je dois faire fonctionner sur différent post. Il utilisait de base MSHFlexGrid dans les userform mais ce n'est plus compaptible, c'est pourquoi je me tourne vers listview.

La fonction AddError ajoute les erreurs s'il y en a dans mon USF sous forme d'une liste. Je n'arrive pas a "convertir" cette fonction mshflexgrid en listview. je suis vraiment nul en VBA...

voici la fonction :

Private Function AddError(ByRef Data As Range, ByVal kind As String, source As String)
    NbErrors = NbErrors + 1
    With UserForm1.ListView1
        If Not (.Rows = 2 And Trim(.TextMatrix(1, 0)) = "") Then .AddItem "", 1
        .TextMatrix(1, 0) = CStr(Format(CDate(Now()), "dd/mm/yy HH:nn"))
        .TextMatrix(1, 1) = source
        .TextMatrix(1, 2) = kind
        .TextMatrix(1, 3) = Data.Parent.Name
        .TextMatrix(1, 4) = Data.Address
        .TextMatrix(1, 5) = Data.Value
        If .Rows Mod 2 = 1 Then
            .row = 1
            For i = 0 To .Cols - 1
                .col = i
                .CellBackColor = &HC0FFC0
            Next
        End If
    End With
End Function

et voici le dit USF en question :

Private Sub UserForm_Initialize()
    '----- remplissage ListView------------------------
    With ListView1
        'Définit le nombre de colonnes et Entêtes
        With .ColumnHeaders
            'Supprime les anciens entêtes
            .Clear
            'Ajoute 3 colonnes en spécifiant le nom de l'entête
            'et la largeur des colonnes
            .Add , , "Date", 120, lvwColumnLeft
            .Add , , "Procédure", 120, lvwColumnCenter
            .Add , , "Attendu", 120, lvwColumnCenter
            .Add , , "Feuille", 120, lvwColumnCenter
            .Add , , "Cellule", 120, lvwColumnCenter
            .Add , , "Donnée Fournie", 158, lvwColumnCenter
        End With
        .Gridlines = True           ' affichage de lignes
    End With
    '--------------------------------------------------
    'Spécifie l'affichage en mode "Détails"
    ListView1.View = lvwReport
End Sub

Merci d'avance pour votre aide

 

[ChTi160]

Bonjour harrissa555
Pourrais tu nous expliquer ce que tu veux faire ,par rapport a ce que tu as？
ainsi qu un petit fichier pour nous permettre de t aider.
merci par avance
jean marie

 

[harissa555]

Bonjour Jean Marie,
sur le fichier initiale, les éventuelles erreurs apparaissaient sous forme de grid dans le usf, mais ce n'est plus compatible. Du coup, j'aimerai convertir ce "rapport d'erreur" en listview. j'ai réussi a créer la listview dans mon usf, mais je n'arrive pas a modifier la fonction adderror pour la rendre compatible avec la listview.

Malheureusement, je n'ai pas le droit de joindre le fichier Excel je suis désolé, je suis en entreprise et le fichier est "confidentiel".
J’espère avoir été clair. n’hésitez pas a me poser d'autre questions.

Merci de l’intérêt que vous portez a mon problème 🙂

 

[ChTi160]

Re
ne peux tu creer un fichier exemple sans donnees confidentielles et l explication de ce que tu veux a partir des donnees que tu dois traiter ,sinon je ne vois pas comment faire.
jean marie

 

[harissa555]

Re,

Je ne suis pas sur des infos supplémentaires que vous voulez. Q'avez vous besoin? Mon problème est juste que s'il y a une erreur, elle apparaît dans ma listview c'est tout. j'ai donc juste besoin d'aide sur comment adapter ma fonction en utilisant les syntaxes de listview.
je ne sais pas si je suis assez clair excusez moi

 

[ChTi160]

Re
ne t embete pas pour moi, peut etre que quelqu un comprendra ce que tu veux et resoudra ton probleme .
Amicalement
jean marie

 

[Hasco]

Bonjour,



TextMatrix n'est pas un membre de ListView. Cherchez du côté de la collection .ListItems et ses .ListSubItems.

Le crossPosting: https://www.developpez.net/forums/d1974337/dotnet/langages/vb-net/remplir-listview/

çà ne donne pas envie d'aller plus loin

Bonne soirée

 

[ChTi160]

Re
Merci Roblochon
jean marie

 

[harissa555]

Bonjour Roblochon,
tu as raison TextMatrix ne fait pas partie de Listview mais de mshflexgrid. d'ou mon problème. je cherche "simplement" a changer les syntaxe textmatrix, additem, rows, ... pour rendre la fonction compatible avec listview pour l'exploiter dans mon USF...

voila ou j'en suis

Private Function AddError(ByRef Data As Range, ByVal kind As String, source As String)
    NbErrors = NbErrors + 1
    With UserForm1.ListView1
        If Not (.Rows = 2 And Trim(.ListItems(1).ListSubItems(0)) = "") Then .AddItem "", 1
        .ListItems.Add , , CStr(Format(CDate(Now()), "dd/mm/yy HH:nn"))
        .ListItems.Add , , source
        .ListItems.Add , , kind
        .ListItems.Add , , Data.Parent.Name
        .ListItems.Add , , Data.Address
        .ListItems.Add , , Data.Value
        If .Rows Mod 2 = 1 Then
            .row = 1
            For i = 0 To .Cols - 1
                .col = i
                .CellBackColor = &HC0FFC0 .Rows = 2 And
            Next
        End If
    End With
End Function

je suis désolé si je ne répond pas a vos attente, peut-être que je ne les comprends pas.

 

[ChTi160]

Bonjour harissa555
Bonjour le Fil ,le Forum
Bon pour pouvoir t'aider il nous faudrait un fichier exemple de ce que tu as et de ce que tu veux .le fichier faut pas compter dessus
donc peut être qu'en nous expliquant la démarche on pourrait arriver a quelque chose .....
donc essais de nous expliquer ce que tu veux et comment tu pense faire
Ex
J'ai une base de données je vérifie dans la base de données les lignes et si ??? (quelque chose) je récupére dans la Listview les éléments suivant .....
Explique nous , à quoi correspondent les

source
kind
Data.Parent.Name
Data.Address
Data.Value

ou ça ce trouve tout ca ?
tu vois plein de questions !
Dans l attente
jean marie

 

[Hasco]

Bonjour,

une simple recherche google donne l'excelent tuto : https://silkyroad.developpez.com/VBA/ListView/

@ChTi160 : les 'source', 'kind' et autres sont semblent-ils des subitems.

Bon après-midi

 

[ChTi160]

Re
Bonjour Roblochon
ça , je l'ai compris depuis longtemps (j'adore les Listview Lol) , mais ou trouve t on tout cela que doit ton vérifier (pour trouver des erreurs) et ainsi remplir cette ListView .
harissa555 dit :

La fonction AddError ajoute les erreurs s'il y en a dans mon USF sous forme d'une liste. Je n'arrive pas a "convertir" cette fonction mshflexgrid en listview.

je pense , qu'il est toujours possible de mettre un fichier exemple , quelques Lignes (Sans données confidentielles) et ainsi permettre de comprendre et Travailler......
Dans l'attente
jean marie

 

[Hasco]

Re,

oui tu as raison🙂

A+

 

[harissa555]

je rencontre le meme cas de figure autre part dans le excel et je serai plus a meme de vous l'expliquer.
je lance ma macro saisie: elle ouvre un autre fichier excel pour importer ses données dans la feuille opéjour du excel principale. si des données sont nouvelles, elle apparaissent dans le userform pour les faire ressortir dur lot et me laisse la possibilité de les ajouter ou non dans ma feuille. puis toute ces infos sont enregistré dans une base de donnée

Option Explicit
Private rst As New ADODB.Recordset
Private cptTri As Long
Private i As Long, j As Long
Private Ins As Boolean, Outs As Boolean

Public Sub Sorties()
    IniSorties
    Me.dtSortiesAu.Value = CDate(Format(Now(), "dd/mm/yy") & " 23:59")
    Me.dtSortiesDu.Value = dtSortiesAu.Value - 7
    If cnx.State = 0 Then Set cnx = Ini_cnx(cnx)
    If rst.State = 0 Then Set rst = Ini_rst(rst)
    MakeQuery
    Outs = True
End Sub

Private Sub MultiPage1_Change()
    'Initialise la page de sorties si pas encore fait
    If MultiPage1.Value = 1 And Not Outs Then Sorties
End Sub

'######### ENTREES
Public Sub IniInsertions()
    With gdInsertions
        .ColAlignment(1) = flexAlignCenterCenter
        .ColAlignment(2) = flexAlignCenterCenter
        .ColAlignment(5) = flexAlignCenterCenter
        .ColWidth(0) = 2000
        .ColWidth(1) = 2000
        .ColWidth(2) = 1600
        .ColWidth(3) = 1400
        .ColWidth(4) = 1400
        .ColWidth(5) = 500
        .TextMatrix(0, 0) = "Isin"
        .TextMatrix(0, 1) = "Maturité"
        .TextMatrix(0, 2) = "Fut"
        .TextMatrix(0, 3) = "Qté"
        .TextMatrix(0, 4) = "Prix"
    End With
End Sub
Private Sub gdInsertions_Click()
    With gdInsertions
        If Trim(.TextMatrix(.row, 0)) <> "" Then
            .col = 0
            Select Case .TextMatrix(.row, 5)
                Case "-"
                    .CellBackColor = &H8000&
                    .col = 5
                    .Text = "+"
                    .CellBackColor = &H8000&
                Case Else
                    .CellBackColor = &HC0&
                    .col = 5
                    .Text = "-"
                    .CellBackColor = &HC0&
            End Select
        End If
    End With
End Sub
Public Sub add_new_val(ByVal j As Integer, isin As String, maturite As Date, type_fut As String, quantite As Long, prix As Double)
'Ajoute une ligne à la table d'insertions, si une valeur n'est pas suivie
    With gdInsertions
        .col = 0
        If j = 13 Then InOut.gdInsertions.ColWidth(0) = 1800
        If j <> 1 Then
            .AddItem isin, j
        Else
            .TextMatrix(j, 0) = isin
        End If
        .row = j
        .col = 0
        Select Case quantite
            Case Is < 0
                .CellBackColor = &HC0&
                .col = 5
                .Text = "-"
                .CellBackColor = &HC0&
            Case Else
                .CellBackColor = &H8000&
                .col = 5
                .Text = "+"
                .CellBackColor = &H8000&
        End Select
        .CellForeColor = &HFFFFFF
        .TextMatrix(j, 1) = maturite
        .TextMatrix(j, 2) = type_fut
        .TextMatrix(j, 3) = quantite
        .TextMatrix(j, 4) = prix
        .col = 2
        .CellAlignment = flexAlignCenterCenter
        .CellFontBold = True
        Select Case type_fut
            Case "BUND"
                .CellForeColor = &HF000&
            Case "BOBL"
                .CellForeColor = &HC0C0&
            Case Else
                .CellForeColor = &HFF8080
        End Select
    End With
End Sub
Private Sub btnInserer_Click()
    RefreshVals     'Rafraichi la liste des valeurs dans pose
    saisie True     'Rafraichi la liste des opérations sur ces valeurs
    Unload Me
End Sub

Private Sub btnPasser_Click()
    If lSaisie.Visible = True Then saisie True  'Si en cours de macro saisie, rafraichissement de la liste des opés
    Unload Me
End Sub




'######### SORTIES
Private Sub IniSorties()
    With Me.gdSorties
        .ColAlignment(0) = flexAlignCenterCenter
        .ColAlignment(1) = flexAlignCenterCenter
        .ColAlignment(2) = flexAlignCenterCenter
        .ColAlignment(5) = flexAlignCenterCenter
        .ColAlignment(6) = flexAlignRightCenter
        .ColAlignment(7) = flexAlignRightCenter
        .ColWidth(0) = 250
        .ColWidth(1) = 1500
        .ColWidth(2) = 1200
        .ColWidth(3) = 1500
        .ColWidth(4) = 1000
        .ColWidth(5) = 800
        .ColWidth(6) = 1000
        .ColWidth(7) = 1000
        .ColWidth(8) = 600
        .ColWidth(9) = 0
        .TextMatrix(0, 1) = "Saisie/Modif"
        .TextMatrix(0, 2) = "Date de valeur"
        .TextMatrix(0, 3) = "Code"
        .TextMatrix(0, 4) = "Quantite"
        .TextMatrix(0, 5) = "Prix"
        .TextMatrix(0, 6) = "Spread/OAT"
        .TextMatrix(0, 7) = "Spread/ASW"
        .TextMatrix(0, 8) = "Statut"
        .row = 0
    End With
End Sub
Private Sub ColorSorties()
'Routine de colorisation de la liste des sorties
    Dim color As Long
    With Me.gdSorties
        .Redraw = False
        For i = .FixedRows To .Rows - 1
            .row = i
            .col = 0
            .CellBackColor = &HFFFFFF
            .CellFontBold = True
            Select Case .TextMatrix(i, 8)
                Case -1
                    color = &HC0C0FF
                Case 0
                    color = &HC0E0FF
                Case 1
                    color = &HC0FFC0
            End Select
            For j = 1 To 8
                .col = j
                If j = 1 Then .Text = Format(CDate(.Text), "dd/mm/yy hh:nn")    'correction date de modif
                .CellBackColor = color
            Next j
        Next i
        .Redraw = True
    End With
End Sub
Private Sub gdSorties_Click()
    Dim col As Integer
    With gdSorties
        .Redraw = False
        If .row > 0 Then
            col = .col
            .col = 0
            Select Case .TextMatrix(.row, 8)
                Case -1
                    If .Text = "" Then
                        .Text = "V"
                        .CellBackColor = &HC000&
                    Else
                        .Text = ""
                        .CellBackColor = &HFFFFFF
                    End If
                Case 0
                    Select Case .Text
                        Case ""
                            .Text = "V"
                            .CellBackColor = &HC000&
                        Case "V"
                            .Text = "A"
                            .CellBackColor = &HC0&
                        Case "A"
                            .Text = ""
                            .CellBackColor = &HFFFFFF
                    End Select
                Case 1
                    If .Text = "" Then
                        .Text = "A"
                        .CellBackColor = &HC0&
                    Else
                        .Text = ""
                        .CellBackColor = &HFFFFFF
                    End If
            End Select
            .col = col
        End If
        .Redraw = True
    End With
End Sub
Private Sub MakeQuery()
'Genere et actualise la requete de la liste sorties
    Exit Sub
    Dim sql As String
    If cnx.State = 0 Then Set cnx = Ini_cnx(cnx)
    If rst.State <> 0 Then rst.Close
    sql = "SELECT MAJ, left(DATE, len(DATE)), ISIN, QTE, left(PRIX,len(PRIX)), left(SPOAT,len(SPOAT)), left(SPASW,len(spasw)), ETAT, [MOD] FROM POSE_SORTIES WHERE MAJ >= #" & Format(CDate(dtSortiesDu), "mm/dd/yy 00:00:00") & "# AND MAJ <= #" & Format(CDate(dtSortiesAu), "mm/dd/yy 23:59:59") & "#"
    sql = sql & FiltreSorties & TriSorties
    rst.Open sql
    With gdSorties
        .Redraw = False
        If rst.RecordCount <> 0 Then
            Set .DataSource = rst
            IniSorties
            ColorSorties
            btnValid.Enabled = True
            .Visible = True
        Else
            .Clear
            Set .DataSource = Nothing
            btnValid.Enabled = False
            .Visible = False
        End If
        .Redraw = True
    End With
End Sub
Private Function FiltreSorties() As String
'Gère les filtres d'affichage (en attente, validées, annulées)
    cptTri = 1
    With Me
        If .cbAtt = True Then cptTri = cptTri * 2
        If .cbVal = True Then cptTri = cptTri * 3
        If .cbAnn = True Then cptTri = cptTri * 4
    End With
    Select Case cptTri
        Case 1, 2       'Uniquement 'En attente' (ou aucune case cochée)
            FiltreSorties = " AND ETAT = 0"
        Case 3          'Uniquement 'Validées'
            FiltreSorties = " AND ETAT = 1"
        Case 4          'Uniquement 'Annulées'
            FiltreSorties = " AND ETAT = -1"
        Case 6          'En attente et Validées
            FiltreSorties = " AND ETAT >= 0"
        Case 8          'En attente et Annulées
            FiltreSorties = " AND ETAT <= 0"
        Case 12         'Annulées et Validées"
            FiltreSorties = " AND ETAT <> 0"
        Case 24         'La totale
            FiltreSorties = ""
    End Select
End Function
Private Function TriSorties() As String
'Gère la tri d'affichage
    If Me.obCode = True Then TriSorties = " ORDER BY ISIN"
    If Me.obEtat = True Then TriSorties = " ORDER BY ETAT"
    If Me.obSaisie = True Then TriSorties = " ORDER BY SAISIE"
End Function
Private Sub help_Click()
    MsgBox "Cliquer une ou plusieurs fois sur la ligne d'une opération pour changer son statut. Les modifications sont visibles dans la colonne de gauche : 'V' pour validée, 'A' pour annulée, et vide pour aucune modification. Appuyer ensuite sur 'Valider les modifications' pour enregistrer celles-ci.", vbInformation, "Gérer les sorties de titres"
End Sub
Private Sub cbAtt_Click()
    MakeQuery
End Sub
Private Sub cbVal_Click()
    MakeQuery
End Sub
Private Sub cbAnn_Click()
    MakeQuery
End Sub
Private Sub obCode_Click()
    MakeQuery
End Sub
Private Sub obEtat_Click()
    MakeQuery
End Sub
Private Sub obSaisie_Click()
    MakeQuery
End Sub
Private Sub dtSortiesDu_Change()
    MakeQuery
End Sub
Private Sub dtSortiesAu_Change()
    MakeQuery
End Sub

Private Sub btnValid_Click()
    If MsgBox("Valider les opérations modifiées ?", vbYesNo, "Valider la selection") = vbYes Then
        Dim Modified As Boolean, NewState As Long
        rst.MoveFirst
        With gdSorties
            For i = 1 To .Rows - 1
                If .TextMatrix(i, 0) = "V" Then NewState = 1
                If .TextMatrix(i, 0) = "A" Then NewState = -1
                If Trim(.TextMatrix(i, 0)) <> "" Then
                    Modified = SelectFlag(rst("ETAT"), NewState, rst("MOD"))
                    rst("ETAT") = NewState
                    rst("MAJ") = Now()
                    rst("MOD") = Modified
                End If
                If rst.EOF Then Exit For
                rst.MoveNext
            Next i
        End With
        rst.UpdateBatch
        MakeQuery
        With ThisWorkbook.Sheets("OpéJour").QueryTables("pose_sorties")
            .CommandText = .CommandText
            .Connection = .Connection
            .Refresh
        End With
    End If
End Sub

Private Function SelectFlag(ByVal OldState As Long, NewState As Long, Modified As Boolean) As Boolean
    SelectFlag = False
    Select Case OldState
        Case 0      'Opérations en attente
            If NewState = 1 Then SelectFlag = True          'Prise en compte si validation
        Case -1     'Opérations Annulées precedemment
            If Modified Then SelectFlag = False             'Annulation de la prise en compte d'une opération annulée ce jour (sauf nouvelles), puis revalidée
            If Not Modified Then SelectFlag = True          'Prise en compte de la validation d'une opération annulée avant aujourdhui, puis revalidée
        Case 1
            If Modified Then SelectFlag = False             'Annulation d'une opération validée aujourdhui
            If Not Modified Then SelectFlag = True          'Prise en compte de l'annulation d'une opération validée avant aujourdhui
    End Select
End Function
'Controler la date
'Update la date en cas de changement
'Querytable excel qui extrait les opé modifiées ce jour

Private Sub UserForm_Click()

End Sub

et voici le module qui gere tout

Option Explicit
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Dim i As Long, j As Long
Private rst As New ADODB.Recordset
Private OpOk As Boolean

Public Sub change_filegl()
'Macro permettant de choisir le chemin d'accès au fichier de dépouillement GL
'Le chemin complet vers le fichier est alors inscrit en path_filegl pour être traité avec la macro SAISIE
'Theoriquement, feuille OpéJour, cellule C3
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        If .Show = -1 Then
            If .SelectedItems.Count <> 1 Then If MsgBox("Choisir le fichier GL !", vbCritical) = vbOK Then Exit Sub
            ThisWorkbook.Sheets("OpéJour").[path_filegl].Value = .SelectedItems.Item(1)
        Else
            If .SelectedItems.Count < 1 Then Exit Sub
        End If
    End With
    Set fd = Nothing
    ThisWorkbook.Sheets("OpéJour").[path_filegl].Select
End Sub
Public Sub saisie(Optional StartAtTwo As Boolean = False)
'Importe les données provenant de GL
'Nécéssite eventuellement l'execution de change_filegl() au préalable
'Ouvre le fichier dont l'adresse est recuperée par change_filegl() et copie la liste des opérations
'Verifie ensuite s'il y a des valeurs qui ne sont pas encore suivies dans pose
    Dim filegl As Object
    Set filegl = CreateObject("scripting.filesystemobject")
    Dim wbgl As Excel.Workbook
    Set wb = ThisWorkbook
    Set sh = wb.Sheets("OpéJour")
    Dim pathgl As String
    pathgl = sh.[path_filegl].Value
    OpOk = False    'Pour la verification de la recopie des opérations

    'Verification étape (si insertion de nouvelles valeurs)
    If StartAtTwo Then GoTo step2
    
    'Verification de l'existence du fichier GL
    If Not filegl.fileexists(sh.[path_filegl]) Then
        sh.Select
        sh.[path_filegl].Select
        MsgBox ("Le fichier " & pathgl & " ne semble pas exister." & Chr(13) & "Verifier l'adresse")
        Exit Sub
    End If
    
    'Synthèse pour spreads
    With wb.Sheets("SynthèseJour")
        .[Synth_area_SpdMoy].Copy
        .[Synth_area_SpdPrec].PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
    End With
    
    'Preparation de la feuille OpéJour
    With sh
        .Select
        .Unprotect
        .[Op_area_saisie].ClearContents
    End With
    
    
    'Ouverture et copie des données
    Workbooks.Open (pathgl)
    Set wbgl = ActiveWorkbook
    wbgl.ActiveSheet.Range("G3").Select
    If Selection.Value <> "" Then
        Range(Selection, Selection.End(xlToRight)).Select
        If Range("G4") <> "" Then Range(Selection, Selection.End(xlDown)).Select
    End If
    Selection.Copy
    With sh
        .Activate
        .[Op_area_saisie].Cells(1, 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .[Op_area_saisie].Cells(1, 1).Select
    End With
    Application.CutCopyMode = False
    
    'Verification de l'existence des valeurs traitées dans pose
    wbgl.Close
    Set wbgl = Nothing
    If check_newvals(True) <> 0 Then
        While Not OpOk
            check_newvals (True)
        Wend
        Exit Sub
    End If
step2:
    CopyOp
    GoTo flush
err:
    sh.[Op_area_saisie].ClearContents
flush:
    wb.Activate
    sh.Protect
    wb.Sheets("Stock").Activate
    Set sh = Nothing
    Set filegl = Nothing
End Sub
Public Sub CopyOp()
'Recopie Opé GL retraitées par les op annulées
'Executé après Insertion/Sortie de valeurs
    sh.Select
    With sh.[Op_liste]
        sh.Range(.Cells(5, 2), .Cells(254, 3)).Copy
        sh.Range(.Cells(5, 4), .Cells(254, 5)).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
    OpOk = True
End Sub
Public Sub vider_position(ByVal isin As String, line As Integer, Optional bOp As Boolean = 1, Optional bOpJour As Boolean = 1, Optional bAuto As Boolean = 0, Optional ancien_typefut As String = "")
    Dim str As String, coln As String, Histo As Range, row As Long
    Dim tmp(0, 8) As Variant
    Set wb = ThisWorkbook
    Set sh = wb.Sheets("OpéJour")
 
    tmp(0, 0) = isin
    If ancien_typefut = "" Then ancien_typefut = sh.[Op_liste].Cells(line + 4, 6)
    'Annuler opérations précédentes
    If bOpJour And CLng(Ventes.lTitresJ) <> 0 Then
        tmp(0, 1) = CLng(Ventes.lTitresJ)
        tmp(0, 2) = CDbl(Ventes.lPrixJ)
        'Inscrit l'annulation de l'opération, pour eviter qu'elle soit reprise en compte à la prochaine saisie GL
        With sh.[Op_annul]
            row = sh.Cells(260, .Column).End(xlUp).row + 1
            sh.Range(sh.Cells(row, .Column), sh.Cells(row, .Column + 2)) = tmp
        End With
        'Vide qte et prix
        sh.[Op_liste].Cells(line + 4, 4) = 0
        sh.[Op_liste].Cells(line + 4, 5) = 0
        sh.Range(sh.[Op_liste].Cells(line + 4, 7), sh.[Op_liste].Cells(line + 4, 10)).ClearContents
    End If
        
    'Vider la position
    Set Histo = wb.Sheets("Data").[histo_j1]
    tmp(0, 1) = 0
    tmp(0, 2) = 0
    tmp(0, 3) = ancien_typefut          'type_fut
    'Opérations
    If (bOp = True Or bAuto = True) And Histo.Cells(line + 2, 1) <> 0 Then
        If bAuto Then
            tmp(0, 1) = -Histo.Cells(line + 2, 1)
        Else
            tmp(0, 1) = -CLng(Ventes.tTitresV)     'quantite
        End If
        tmp(0, 2) = Histo.Cells(line + 2, 2)       'prix
        str = str & Chr(13) & tmp(0, 1) & " titres à " & tmp(0, 2)
    End If
    'Futures
    If (CDbl(Ventes.tEurexV) <> 0 Or CDbl(Ventes.tSwapnotesV) <> 0 Or bAuto = True) Then
        If bAuto Then
            tmp(0, 4) = -Histo.Cells(line + 2, 5)
            tmp(0, 6) = -Histo.Cells(line + 2, 7)
        Else
            tmp(0, 4) = -CDbl(Ventes.tEurexV)
            tmp(0, 6) = -CDbl(Ventes.tSwapnotesV)
        End If
        tmp(0, 5) = Histo.Cells(line + 2, 6)
        tmp(0, 7) = Histo.Cells(line + 2, 8)
        str = str & Chr(13) & tmp(0, 4) & " " & tmp(0, 3) & " à " & tmp(0, 5)
        str = str & Chr(13) & tmp(0, 6) & " swapnotes à " & tmp(0, 7)
    End If
    'Information sur la quantité et le type de future à vendre pour compenser la mise à zero de la couverture
    If bAuto Then str = str & Chr(13) & Chr(13) & "A ajouter dans dépou89222 : " & -tmp(0, 1) & " titres à " & Round(wb.Sheets("Data").Cells(line + 9, RechercheNumCol("PxRevient", 9, wb.Sheets("Data"), 1)), 2)
    
    'Vidage effectif
    If (CLng(tmp(0, 1)) <> 0 And bOp = True) Or ((CDbl(tmp(0, 4)) <> 0 Or CDbl(tmp(0, 6)) <> 0)) Then
        str = "Opérations réalisées : " & isin & Chr(13) & str
        With sh.[Op_vidage]
            row = sh.Cells(260, .Column).End(xlUp).row + 1
            sh.Range(sh.Cells(row, .Column), sh.Cells(row, .Column + 7)) = tmp
        End With
        Set sh = wb.Sheets("SynthèseJour")
        With sh.[Ventes]
            If Not bAuto Then
                row = sh.Cells(260, .Column).End(xlUp).row + 1
                tmp(0, 1) = CLng(Ventes.tQuantite)
                tmp(0, 2) = CDbl(Ventes.lPxRev)
                tmp(0, 3) = CDbl(Ventes.lSpRev)
                tmp(0, 4) = CDbl(Ventes.tPrix)
                tmp(0, 5) = CDbl(Ventes.tSpasw)
                If Ventes.tSociete <> "Ou saisie manuelle..." Then tmp(0, 6) = Ventes.tSociete Else tmp(0, 6) = "-"
                If Ventes.tClient <> "Ou saisie manuelle..." Then tmp(0, 7) = Ventes.tClient Else tmp(0, 7) = "-"
                tmp(0, 8) = Now()
                sh.Range(sh.Cells(row, .Column), sh.Cells(row, .Column + 8)) = tmp
            End If
        End With
        MsgBox str, vbInformation
    End If
 
    Set sh = Nothing
    Set wb = Nothing
End Sub


Public Function update_opjour(Optional ByVal UpHisto As Boolean = True) As Boolean
'Update des opérations du jour vers access
'Vide la précédente table temporaire et la rempli à nouveau avec les opérations
    Set wb = ThisWorkbook
    Set sh = wb.Sheets("OpéJour")
    Dim rstv As New ADODB.Recordset
    ReInitErrors
    
'Parametrage formulaire & Verification des cours des futures
    Dim curprixfut As Double, curprixsn As Double, Errcours As Integer
    Dim strErr As String
   ' With HistoAccess
    '    .StatusBar.Panels(1).Text = "Verification cours futures"
     '   .ProgressBar.max = 259
     '   .MultiPage1.Value = 0
     '   .MultiPage1.Style = fmTabStyleNone
      '  If UpHisto Then
      '      .Et_lTitre.Caption = "Execution : Update des opérations du jour"
      '      .Et_l1.Caption = "Verification des cours des futures..."
       '     .Et_l2.Caption = "Enregistrement des positions vidées..."
       '     .Et_l3.Caption = "Enregistrement des opérations..."
        '    .Et_l4.Caption = "Mise à jour historique pour Konzult..."
       '     .Et_l5.Caption = "Enregistrement des résultats..."
       '     .Et_l6.Caption = "Enregistrement des coupons..."
        '    .Et_l7.Caption = "Verification des erreurs..."
         '   HistoAccess.Et_btnClose.Enabled = False
         '   .Show
       ' End If
   ' End With
    With sh.[Op_liste]
        For i = 5 To 264
           ' HistoAccess.ProgressBar.Value = i - 5
            If .Cells(i, 1).Value <> "" Then
           '     HistoAccess.StatusBar.Panels(1).Text = "Verification cours futures - " & .Cells(i, 1)
            '    HistoAccess.Repaint
                Select Case .Cells(i, 6).Value
                    Case "BUND"
                        curprixfut = sh.[CoursBund].Value
                        curprixsn = sh.[CoursSn10].Value
                    Case "BOBL"
                        curprixfut = sh.[CoursBobl].Value
                        curprixsn = sh.[CoursSn5].Value
                    Case "SCHATZ"
                        curprixfut = sh.[CoursSchatz].Value
                        curprixsn = sh.[CoursSn2].Value
                End Select
                If (.Cells(i, 8) <> "" And .Cells(i, 8) <> 0) Or (.Cells(i, 7) <> "" And .Cells(i, 7) <> 0) Or (.Cells(i, 10) <> "" And .Cells(i, 10) <> 0) Or (.Cells(i, 9) <> "" And .Cells(i, 9) <> 0) Then
                    Errcours = 0
                    If .Cells(i, 7) > 0 And (.Cells(i, 8) < curprixfut - sh.[FourchetteFut] * 100 Or .Cells(i, 8) > curprixfut + sh.[FourchetteFut] * 100) Then Errcours = 1
                    If .Cells(i, 9) > 0 And (.Cells(i, 10) < curprixsn - sh.[FourchetteSn] * 100 Or .Cells(i, 10) > curprixsn + sh.[FourchetteSn] * 100) Then Errcours = 2
                    If Errcours > 0 Then
                        If wb.Sheets("Stock").ChercheLycos(.Cells(i, 1), 5, 2) = False Then
                            sh.Activate
                            .Cells(i, 8).Activate
                            strErr = "Valeur introuvable dans stock (" & .Cells(i, 1) & ")" & Chr(13) & Chr(13)
                        End If
                        If UpHisto Then
                    '        HistoAccess.Et_mR1.Caption = "Cours incohérent"
                     '       HistoAccess.Et_mR1.Visible = True
                        End If
                        If MsgBox(strErr & "Ce cours semble incohérent par rapport au prix de marché. Stopper la macro et corriger ?", vbYesNo) = vbYes Then GoTo fin
                    End If
                End If
            End If
        Next i
    End With
   ' If UpHisto Then HistoAccess.Et_mG1.Visible = True
    
'Paramètres de la connexion
    If cnx.State = 0 Then Set cnx = Ini_cnx(cnx)
    If rst.State = 0 Then Set rst = Ini_rst(rst)
    If rstv.State = 0 Then Set rstv = Ini_rst(rstv)
    
'Paramètres du recordset
    With rst
        .Open "DELETE FROM POSE_OPERATIONS_JOUR", cnx, adOpenStatic, adLockOptimistic
        .Open "SELECT * FROM POSE_OPERATIONS_JOUR", cnx, adOpenStatic, adLockOptimistic
    End With
 
'Update Sorties pour stats
    rstv.Open "DELETE * FROM POSE_SORTIES WHERE DATE = #" & Format(ThisWorkbook.Sheets("Informations").[workdate], "mm/dd/yy") & "#", cnx, adOpenStatic, adLockOptimistic
    rstv.Open "SELECT * FROM POSE_SORTIES", cnx, adOpenStatic, adLockOptimistic
    With wb.Sheets("SynthèseJour").[Ventes]
        For i = 3 To 252
            If .Cells(i, 1) <> "" Then
                rstv.AddNew
                rstv("DATE") = Format(Check_Data(.Cells(i, 9), "Date", "Ventes"), "dd/mm/yy 00:00")
                rstv("ISIN") = Check_Data(.Cells(i, 1), "String", "Ventes")
                rstv("QTE") = Check_Data(.Cells(i, 2), "Double", "Ventes")
                rstv("PXREV") = Check_Data(.Cells(i, 3), "Double", "Ventes")
                rstv("SPREV") = Check_Data(.Cells(i, 4), "Double", "Ventes")
                rstv("PRIX") = Check_Data(.Cells(i, 5), "Double", "Ventes")
                rstv("SPASW") = Check_Data(.Cells(i, 6), "Double", "Ventes")
                rstv("SOCIETE") = Check_Data(.Cells(i, 7), "String", "Ventes")
                rstv("CLIENT") = Check_Data(.Cells(i, 8), "String", "Ventes")
            End If
        Next i
    End With
  '  If UpHisto Then HistoAccess.Et_mG2.Visible = True
    
'Mise à jour des positions vidées
    With sh.[Op_vidage]
        For i = 5 To 254
      '      With HistoAccess
       '         .StatusBar.Panels(1).Text = "Mise à jour des positions vidées - " & Round((i - 5) / 374 * 100, 0) & "%"
        '        .ProgressBar.Value = i - 5
          '      .Repaint
         '   End With
            If .Cells(i, 1) <> "" Then Call addop(rst, sh.[Op_vidage], CInt(i), 0, "Update DB")
        Next i
    End With
    
'Mise à jour des opérations
    With sh.[Op_liste]
        i = 5
     '   HistoAccess.ProgressBar.max = wb.Sheets("Data").[histo_j].Cells(3, 1).End(xlDown).row - 10
        For i = 5 To wb.Sheets("Data").[histo_j].Cells(3, 1).End(xlDown).row - 5
          '  With HistoAccess
           '     .StatusBar.Panels(1).Text = "Mise à jour des opérations - " & Round((i - 5) / (HistoAccess.ProgressBar.max) * 100, 0) & "%"
           '     .ProgressBar.Value = i - 5
            '    .Repaint
           ' End With
            If .Cells(i, 1) <> "" And (.Cells(i, 4) <> 0 Or .Cells(i, 7) <> 0 Or .Cells(i, 9) <> 0) Then
               Call addop(rst, sh.[Op_liste], CInt(i), 2, "Update DB")
               rst.Update
            End If
        Next i
    End With
    'If UpHisto Then HistoAccess.Et_mG3.Visible = True
    
'Update et fermerture du recordset
    With rst
        If Not .RecordCount = 0 Then
            .UpdateBatch
            If .State <> 0 Then .Close
        End If
    End With
    With rstv
        If Not .RecordCount = 0 Then
            .UpdateBatch
            If .State <> 0 Then .Close
        End If
    End With
 
'Update Histo pour Konzult
    If UpHisto Then
        Save_Histo_tmp "Update DB"
     '   HistoAccess.Et_mG4.Visible = True
    End If
 
'Update résultats
    With wb.Sheets("SynthèseJour")
        If rstv.State <> adStateClosed Then rstv.Close
        rstv.Open "DELETE FROM POSE_RESULTATS WHERE [DATE] = #" & Format(CDate(wb.Sheets("Informations").[workdate].Value), "YYYY/mm/dd") & "#"
        rstv.Open "POSE_RESULTATS"
        For i = 8 To 257
            If .Cells(i, 13) = "" Then Exit For
            rstv.AddNew
            rstv("DATE") = wb.Sheets("Informations").[workdate]
            rstv("ISIN") = Check_Data(.Cells(i, 13), "String", "Pointage")
            rstv("STOCK") = Check_Data(.Cells(i, 29), "Double", "Pointage")
            rstv("ACHATS") = Check_Data(.Cells(i, 30), "Double", "Pointage")
            rstv("VENTES") = Check_Data(.Cells(i, 31), "Double", "Pointage")
            rstv("COUPONS") = Check_Data(.Cells(i, 32), "Double", "Pointage")
        Next i
        rstv.UpdateBatch
       ' HistoAccess.Et_mG5.Visible = True
    End With
 
'Update coupons
    With wb.Sheets("Pointage")
        If .[CpnDetach] > 0 Then
            If rstv.State <> adStateClosed Then rstv.Close
            rstv.Open "DELETE FROM POSE_COUPONS WHERE [DATE] = #" & Format(CDate(wb.Sheets("Informations").[workdate].Value), "YYYY/mm/dd") & "#"
            rstv.Open "POSE_COUPONS"
            j = 0
            For i = 8 To 257
                If .Cells(i, 19) = True And .Cells(i, 19) <> "" Then
                    rstv.AddNew
                    rstv("DATE") = wb.Sheets("Informations").[workdate]
                    rstv("ISIN") = Check_Data(.Cells(i, 3), "String", "Pointage")
                    rstv("TITRES") = Check_Data(.Cells(i, 5), "Long", "Pointage")
                    rstv("MONTANT") = Check_Data(.Cells(i, 16), "Double", "Pointage")
                    rstv("TAUX") = Check_Data(wb.Sheets("Data").Cells(.Cells(i, 1) + 9, 31), "Double", "Pointage")
                End If
            Next i
            rstv.UpdateBatch
        End If
     '  HistoAccess.Et_mG6.Visible = True
    End With
    
'Fin de la macro
    Set rst = Flush_rst(rst, False, True)
    Set rstv = Flush_rst(rstv, False, True)
    If UpHisto Then Set cnx = Flush_cnx(cnx)
  '  With HistoAccess
   '     .StatusBar.Panels(1).Text = "Update terminé !"
    '    .Et_btnClose.Enabled = True
     '   .Repaint
   ' End With
    update_opjour = True
    Call check_histo
    Check_Errors
   ' If UpHisto Then HistoAccess.Et_mG7.Visible = True
    Exit Function
 
'Si erreur plus haut
fin:
   ' Unload HistoAccess
    update_opjour = False
    Check_Errors
End Function
 

Function addop(rst As Recordset, Rng As Range, line As Integer, x As Integer, source As String)
    source = source & " > Enregistrement Op"
    With Rng
        rst.AddNew
        rst("DATE") = ThisWorkbook.Sheets("Informations").[workdate]
        rst("MAJ") = CDate(Now())
        rst("ISIN") = Check_Data(.Cells(line, 1), "String", source)
        If .Cells(line, 2) < 0 Then rst("SENS") = "V" Else: rst("SENS") = "A"
        rst("QUANTITE") = Check_Data(.Cells(line, 2 + x), "Double", source)
        rst("PRIX") = Check_Data(.Cells(line, 3 + x), "Double", source)
        rst("ASW") = Check_Data(ThisWorkbook.Sheets("SynthèseJour").[Synth_area_SpdMoy].Cells(line - 4, 3), "Double", source)
        If x = 0 Then rst("ASW") = Check_Data(.Cells(line, 12), "Double", source)
        rst("TYPE_FUT") = Check_Data(.Cells(line, 4 + x), "String", source)
        rst("QTE_FUT") = Check_Data(.Cells(line, 5 + x), "Double", source)
        rst("PX_FUT") = Check_Data(.Cells(line, 6 + x), "Double", source)
        rst("QTE_SN") = Check_Data(.Cells(line, 7 + x), "Double", source)
        rst("PX_SN") = Check_Data(.Cells(line, 8 + x), "Double", source)
    End With
End Function

Public Function check_newvals(Optional ByVal auto As Boolean = False) As Long
'Verifie l'existence ds posenego des valeurs non présentes dans le stock
 
  '--AJOUT MS --------------------------------------------------
  Dim strLecheance As String
  Dim strLFutrure As String


    Set wb = ThisWorkbook
    Set sh = wb.Sheets("Opéjour")
    Dim isin As String, type_fut As String, maturite As Date, quantite As Long, prix As Double
    With sh.[Op_area_saisie]
        i = 1
        j = 0
        While .Cells(i, 1).Value <> ""
            'Si la valeur n'est pas encore suivie
             If .Cells(i, 6).Value = 0 Then
                              
                quantite = .Cells(i, 2) - .Cells(i, 5)
                If quantite <> 0 Then
                
                
                
                    isin = .Cells(i, 1).Value
                    prix = (.Cells(i, 2) * .Cells(i, 3) - .Cells(i, 4) * .Cells(i, 5)) / quantite
                    j = j + 1
                    'Requete des paramètres de la valeur : Maturité et Couverture
                    
                    
                    
                      '--AJOUT MS --------------------------------------------------
                    If .Cells(i, 40).Value <> "" Then
                        strLecheance = .Cells(i, 40).Value
                        If IsDate(strLecheance) Then
                        
                            strLecheance = .Cells(i, 40)
                            strLFutrure = Fonctions.FutureByMaturity(CDate(strLecheance))
                            
                        Else
                        End If
                    End If
                    
                    With RicInfos
                        If j = 1 Then
                            InOut.IniInsertions
                            .Autohide = "X"
                            Dim rtfields(0) As String
                            rtfields(0) = "RICS"
                        End If
                        .lIsin = isin
                        RtInst1.RtQuery .lIsin, rtfields, , "code"
                        'Ajout effectif dans la liste d'attente
                                              
                        '--AJOUT MS --------------------------------------------------
                        'InOut.add_new_val j, isin, CDate(.Lecheance), .Lfuture, quantite, prix
                        
                        'If IsDate(strLecheance) Then
                          InOut.add_new_val j, isin, CDate(strLecheance), strLFutrure, quantite, prix
                        'Else
                          'InOut.add_new_val j, isin, CDate("28/06/2020"), strLFutrure, quantite, prix
                        'End If
                    End With
                End If
            End If
            i = i + 1
        Wend
        
        check_newvals = j
    'Affichage du formulaire d'insertion des nouvelles valeurs
    'Si au moins 1 nvlle val, et si procédure automatique (pendant saisie)
        If j > 0 And auto = True Then
            InOut.MultiPage1.Value = 0
            InOut.lSaisie.Visible = True
            InOut.btnPasser.Caption = "PASSER"
            InOut.Show
        End If
    End With
End Function
Public Sub RefreshVals()
    'Ajoute les nouvelles valeurs qui ne sont pas encore dans HISTO
    Set wb = ThisWorkbook
    Dim RstRef As New ADODB.Recordset
    'Si validation, insertion des valeurs selectionnées
    'Remplissage d'un tableau temporaire pour l'insertion dans le classeur
    'Et insertion directe dans un recordset pour la base de données
    With InOut.gdInsertions
        If cnx.State = 0 Then Set cnx = Ini_cnx(cnx)
        If rst.State = 0 Then Set rst = Ini_rst(rst)
        Set RstRef = Ini_rst(RstRef)
        rst.Open "POSE_VALEURS"
        RstRef.Open "VALEURS_REFERENTIEL", , , , adCmdTableDirect
        RstRef.Index = "ISIN"
        i = 1
        j = 0
        While i <= .Rows - 1
            If .TextMatrix(i, 5) <> "-" Then
                rst.AddNew
                rst("ISIN") = .TextMatrix(i, 0)
                rst("ECHEANCE") = .TextMatrix(i, 1)
                rst("TYPE_FUT") = .TextMatrix(i, 2)
                'rst("OPERATEUR") = GetOperator     N'existe pas pour l'instant (inutile)
                j = j + 1
            End If
            With RstRef
                .Seek rst("ISIN"), adSeekLastEQ
                If .EOF Then
                    .AddNew
                    RstRef("ISIN") = rst("ISIN")
                End If
            End With
            i = i + 1
        Wend
    End With
    
    If j > 0 Then rst.Update                'Update dernier enregistrement pour actualiser la mise a jour
    rst.UpdateBatch
    RstRef.UpdateBatch
    Set rst = Flush_rst(rst, True, True)    'Update complet, fermerture, et liberation mémoire
    Set RstRef = Flush_rst(RstRef, True, True)
    Set cnx = Flush_cnx(cnx)
 
    RefreshHisto

End Sub

Public Sub RefreshHisto()
'Actualisation des Querytables (feuille Data)
    Set wb = ThisWorkbook
    With wb.Sheets("Data")
        With .QueryTables("histo_veille")
            .Connection = .Connection
            .CommandText = .CommandText
            .Refresh BackgroundQuery:=False
        End With
        With .QueryTables("liste_valeurs")
            .Connection = .Connection
            .CommandText = .CommandText
            .Refresh BackgroundQuery:=False
        End With
    End With
End Sub

je reste a votre disposition et encore merci pour votre temps

 

[harissa555]

en ayant longuement parlé avec la personne qui utilise le excel (il marche sur sont pc mais pas moi, les outils MSHFlexgrid ne fonctionnent que chez lui pas de chance) il m'a dit que le userform d'erreur ne s'est jamais affiché et en lisant le code il ne sert a rien... tant d'heure perdu a essayer de comprendre un truc inutile et vous faire perdre votre temps j'en suis navré. mais la saisie que j'ai présenté dans mon post précédent est utilisée