Pas de remplissage des cellules dans un fichier Excel

Majo88 -  
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,

Ce code VBA Access me permet d'ouvrir un fichier Excel existant et d'y insérer des données en appuyant sur bouton. Le problème c'est que le fichier s'affiche sans un seul changement. Les valeurs utilisées pour les remplir s'affichent parfaitement dans MsgBox mais les cellules du fichier indiqué restent vide. 

Dim xls As excel.Application
Dim wrb As excel.Workbook
Set xls = New excel.Application 
Set wrb = xls.Workbooks.Open("D:\Base mesure gainage\PV_modele.xlsx") 
wrb.Sheets(1).Activate
xls.Visible = True
With wrb.Sheets(1) 
    .Range("I3:N3").Value = val1 & "-" & val2    
    .Range("H5:I5").Value = d 
    .Range("H6:I6").Value = h    
    .Range("H7:I7").Value = tab1(25)     
    .Range("H8:I8").Value = Me.cboMachine
    .Range("N5:O5").Value = tab1(21)
    .Range("N6:O6").Value = tab1(27)
    .Range("N7:O7").Value = tab1(23)
    .Range("C15").Value = Round(CDec(tab1(64)), 2)
    .Range("E15").Value = Round(CDec(tab1(63)), 2)     
    .Range("G15").Value = Round(CDec(tab1(62)), 2)     
    .Range("I15").Value = Round(CDec(tab1(16)), 2)     
    .Range("L15").Value = Round(CDec(tab1(15)), 2) 
   .Range("N15").Value = Round(CDec(tab1(14)), 2) 
End With
Set wrb = Nothing
Set xls = Nothing


Merci

3 réponses

  1.
    michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour,

    Comment veux tu qu'on essaies de t'aider car on ne sait pas à quoi correspondent tes variables et d'où elles viennent
    val1, val2, Tabl().... ect dans quel code ?

    il y a un msgbox, dans quel code ?

    enfin en général pour ce genre de pb, je partirais plutôt des antécédents qui font que ton classeur reste vide

    tu vois...

    0
  2. Majo88
     
    Oui j'ai oublier de préciser pour les variables. Les MsgBox c'était juste pour tester si mes modifications de valeur fonctionnais correctement, il ne sont plus dans le code. Tout s'éxécute correctement au début, c'est à partir des lignes en gras que ça pose problème. Voici le code complet : 

    Option Compare Database
Option Explicit

Private Sub OK_Click()
Dim ch As String
Dim strligne As String
Dim tab1() As String
Dim deb As String
Dim fin As String
Dim tab2() As String
Dim d, h As String
Dim val1 As Long
Dim val2 As String
Dim val3, val4, val5, val6, val7, val8, val9, val10 As Single

Open "D:\Base mesure gainage\QUASAR.dat" For Input As #1
While Not EOF(1)
Line Input #1, strligne
Wend
Close 1

Dim i  As Integer
Dim dec As Single
tab1() = Split(strligne, vbTab) 'Découpe la chaine selon les espaces
For i = 0 To UBound(tab1())
    tab1(i) = Replace(tab1(i), ".", ",")
Next i
deb = InStr(strligne, "[") 'Recherche un crochet ouvrant
fin = InStr(strligne, "]") 'Recherche un crochet fermant
ch = Mid(strligne, deb, fin) 'Retourne une chaîne compris entre deux caractères
ch = Replace(ch, "[", "") 'Supprime le premier caractère
ch = Replace(ch, "]", "") 'Supprime le dernier caractère
ch = Replace(ch, " ", "") 'Supprime les espaces
tab2() = Split(ch, ",") 'Découpe la chaine selon les virgules
For i = 0 To UBound(tab2())
    tab2(i) = Replace(tab2(i), ".", ",")
Next i

Set db = CurrentDb()
Dim db As DAO.Database
Dim rst1, rst2 As DAO.Recordset
Set rst1 = db.OpenRecordset("SELECT * FROM Produits WHERE idProduit = " & Me.cboProduit.Column(0, Me.cboProduit.ListIndex))
val1 = rst1("codeProduit")
val2 = rst1("designationProduit")
val3 = rst1("toleranceEpaisseurMin")
val4 = rst1("toleranceEpaisseurMoyMin")
val5 = rst1("toleranceEpaisseurMoyMax")
val6 = rst1("toleranceEpaisseurMax")
val7 = rst1("toleranceDiametreMin")
val8 = rst1("toleranceDiametreMoyMin")
val9 = rst1("toleranceDiametreMoyMax")
val10 = rst1("toleranceDiametreMax")
rst1.Close
Set rst1 = Nothing

Set rst2 = db.OpenRecordset("mesures")
rst2.AddNew
    rst2("aireGaine") = Round(CDec(tab1(3)), 2)
    rst2("excentrement") = Round(CDec(tab1(6)), 2)
    rst2("diametreIntMax") = Round(CDec(tab1(11)), 2)
    rst2("diametreIntMoy") = Round(CDec(tab1(12)), 2)
    rst2("diametreIntMin") = Round(CDec(tab1(13)), 2)
    rst2("diametreOutMax") = Round(CDec(tab1(14)), 2)
    rst2("diametreOutMoy") = Round(CDec(tab1(15)), 2)
    rst2("diametreOutMin") = Round(CDec(tab1(16)), 2)
    rst2("touret") = tab1(21)
    rst2("commande") = tab1(23)
    rst2("machine") = Me.cboMachine
    rst2("operateur") = tab1(25)
    rst2("longueurTouret") = tab1(27)
    rst2("dateMesure") = CDate(tab1(49))
    rst2("ovalite") = CDec(tab1(52))
    rst2("epaisseurMax") = Round(CDec(tab1(62)), 2)
    rst2("epaisseurMoy") = Round(CDec(tab1(63)), 2)
    rst2("epaisseurMin") = Round(CDec(tab1(64)), 2)
    rst2("epaisseur1") = Round(CDec(tab2(0)), 2)
    rst2("epaisseur2") = Round(CDec(tab2(1)), 2)
    rst2("epaisseur3") = Round(CDec(tab2(2)), 2)
    rst2("epaisseur4") = Round(CDec(tab2(3)), 2)
    rst2("epaisseur5") = Round(CDec(tab2(4)), 2)
    rst2("epaisseur6") = Round(CDec(tab2(5)), 2)
    rst2("toleranceEpaisseurMin") = val3
    rst2("toleranceEpaisseurMoyMin") = val4
    rst2("toleranceEpaisseurMoyMax") = val5
    rst2("toleranceEpaisseurMax") = val6
    rst2("toleranceDiametreMin") = val7
    rst2("toleranceDiametreMoyMin") = val8
    rst2("toleranceDiametreMoyMax") = val9
    rst2("toleranceDiametreMax") = val10
rst2.Update
rst2.Close
Set rst2 = Nothing
Set db = Nothing

'Séparation de la date(jj/mm/yyyy) de dateMesure
If Len(Month(CDate(tab1(49)))) = 1 Then
d = Day(CDate(tab1(49))) & "/" & 0 & Month(CDate(tab1(49))) & "/" & Year(CDate(tab1(49)))
Else
d = Day(CDate(tab1(49))) & "/" & Month(CDate(tab1(49))) & "/" & Year(CDate(tab1(49)))
End If
h = Hour(CDate(tab1(49))) & ":" & Minute(CDate(tab1(49))) & ":" & Second(CDate(tab1(49))) 'Séparation de l'heure(hh:mm:ss) de dateMesure

Dim x1 As excel.Application
Dim work As excel.Workbook
Dim wrb As excel.Workbook
Set x1 = New excel.Application
x1.Visible = True
Set wrb = x1.Workbooks.Open(CurrentProject.Path & "\PV_modele.xlsx")  'Démarrer Excel
With wrb.Sheets(1) 'Insertion des valeurs
    .Range("I3").Value = val1 & "-" & val2 'codeProduit + designationProduit
    .Range("H5").Value = d 'date
    .Range("H6").Value = h 'heure
    .Range("H7").Value = tab1(25) 'operateur
    .Range("H8").Value = Me.cboMachine 'machine
    .Range("N5").Value = tab1(21) 'touret
    .Range("N6").Value = tab1(27) 'longueurTouret
    .Range("N7").Value = tab1(23) 'commande
    .Range("C15").Value = Round(CDec(tab1(64)), 2) 'epaisseurMin
    .Range("E15").Value = Round(CDec(tab1(63)), 2) 'epaisseurMoy
    .Range("G15").Value = Round(CDec(tab1(62)), 2) 'epaisseurMax
    .Range("I15").Value = Round(CDec(tab1(16)), 2) 'diametreMin
    .Range("L15").Value = Round(CDec(tab1(15)), 2) 'diametreMoy
    .Range("N15").Value = Round(CDec(tab1(14)), 2) 'diametreMax
    .Range("D15").Value = val3 'toleranceEpaisseurMin
    .Range("F15").Value = val4 'toleranceEpaisseurMoyMin
    .Range("H15").Value = val6 'toleranceEpaisseurMax
    .Range("J15").Value = val7 'toleranceDiametreMin
    .Range("K15").Value = val8 'toleranceDiametreMoyMin
    .Range("M15").Value = val9 'toleranceDiametreMoyMax
    .Range("O15").Value = val10 'toleranceDiametreMax
End With

If CDec(tab1(64)) < val3 Then
wrb.Worksheets(1).Range("C15").Interior.Color = vbGreen
Else
wrb.Worksheets(1).Range("C15").Interior.Color = vbRed
End If

If CDec(tab1(63)) > val4 And CDec(tab1(63)) < val5 Then
wrb.Worksheets(1).Range("E15").Interior.Color = vbGreen
Else
wrb.Worksheets(1).Range("E15").Interior.Color = vbRed
End If

If CDec(tab1(62)) > val6 Then
wrb.Worksheets(1).Range("G15").Interior.Color = vbGreen
Else
wrb.Worksheets(1).Range("G15").Interior.Color = vbRed
End If

If CDec(tab1(16)) < val7 Then
wrb.Worksheets(1).Range("I15").Interior.Color = vbGreen
Else
wrb.Worksheets(1).Range("I15").Interior.Color = vbRed
End If

If CDec(tab1(15)) > val8 And CDec(tab1(15)) < val9 Then
wrb.Worksheets(1).Range("L15").Interior.Color = vbGreen
Else
wrb.Worksheets(1).Range("L15").Interior.Color = vbRed
End If

If CDec(tab1(14)) > val10 Then
wrb.Worksheets(1).Range("N15").Interior.Color = vbGreen
Else
wrb.Worksheets(1).Range("N15").Interior.Color = vbRed
End If

Set wrb = Nothing
Set x1 = NothingEnd Sub
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      Désolé, je ne vois pas...

      Rst1 se remplit il bien? valeur de val1, 2.... ?


      je travaille avec ADODB et non DAO: peut-^tre quelque chose qui m'échappe §

      note: quand j'ai un recordset je teste (adodb) If Rst1.EOF then goto erreur
      0
  3. Majo64
     
    J'ai trouvé. Ca ne venait pas du code VBA Access mais de la macro ScreenUpdating dans Excel qui était à false. Je l'ai donc mis à true.
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      .... DE RIEN
      0

Discussions similaires

Impossible fusionner cellules
aubli -
Christian -

3 réponses