Discussion :

[Rob's]

Bonjour à tous,

Actuellement j'ai créé 2 documents Excel avec chacun des programmes vba.
Le 1er (MC_fonctionne) me permet, par un userform, de récolter des informations.
Le 2nd (MC_JCB_test) doit être capable d'aller chercher les infos rentrées dans le 1er document.

C'est à dire, j'ouvre mon document nommé "MC_JCB_test". Dans l'onglet "Menu" je clique sur le bouton "Extraction hebdomadaire" et à ce moment là, une boîte de dialogue me demande le numéro de semaine souhaité.
Puis, mon programme recherche toutes les infos rentrées dans "MC_fonctionne" correspondant à cette semaine.
Une fois qu'il a trouvé toutes les infos, il me les écrit dans l'onglet "Synthese".

Le problème que je rencontre c'est qu'il n'arrive pas à lire les infos de "MC_fonctionne" et m'affiche un message d'erreur :"Erreur définie par l'application ou par l'objet"

Voici le programme qui me pose soucis (ligne en rouge ou le message apparait):

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
Option Explicit
Option Base 1

Sub Extraction_Hebdo()
  Dim tblo, tblo1, xchoixnosem As Long
  Dim i As Long, j As Long, xdlgn As Long, xlgn As Long
  Application.ScreenUpdating = False
  
  ' Contrôle de la saisie
  'ATTENTION LE BOUTON DE COMMANDE ANNULER DE INPUTBOX GENERE UNE ERREUR
  xchoixnosem = 0
  xchoixnosem = InputBox(Prompt:="NE PAS CLIQUER SUR LE BOUTON DE COMMANDE ANNULER - Indiquez le numéro de semaine (chiffre compris entre 1 et 52), puis Valider par la touche Entrée du clavier ?", Title:="Choix de la semaine")
      If xchoixnosem < 1 Or xchoixnosem > 52 Then
          MsgBox "Le numéro de la semaine doit être un chiffre compris entre 1 et 52.", vbCritical, "Choix de la semaine"
          Application.ScreenUpdating = True
          Exit Sub
      End If

  ' Extraction des données
    With Workbooks("MC_fonctionne.xlsm").Sheets("Synthese")
    .Activate
      
      ' Transfert des données de la feuille dans un array
      tblo = .Range("A6:N" & xdlgn).Value
      ' Tri des données
      ' Code non réalisé
    End With
      
      ' Copy tblo dans tblo1
      ReDim tblo1(LBound(tblo, 1) To UBound(tblo, 1), LBound(tblo, 2) To UBound(tblo, 2))
      xlgn = 0
      For i = LBound(tblo, 1) To UBound(tblo, 1)
        For j = LBound(tblo, 2) To UBound(tblo, 2)
          If tblo(i, 14) = xchoixnosem Then
            tblo1(i, j) = tblo(i, j)
            xlgn = xlgn + 1
          End If
        Next j
      Next i
      
      ' Test si donnees trouvees
      If xlgn = 0 Then
        With Workbooks("MC_JCB_test.xlsm").Sheets("Synthese")
          .Activate
          xdlgn = .Range("A" & Rows.Count).End(xlUp).Row + 1
          .Range("A2:N" & xdlgn).ClearContents
        End With
        With Workbooks("MC_JCB_test.xlsm").Sheets("Menu")
          .Activate
            Application.ScreenUpdating = True
          .Range("A1").Select
        End With
        MsgBox "Aucun résultat pour la semaine no. " & xchoixnosem
        Exit Sub
      End If

      ' Transfert des données de tblo1 dans la feuille - Code à améliorer suppression des lignes vides dans le tableau
      With Workbooks("MC_JCB_test.xlsm").Sheets("Synthese")
        .Activate
        xdlgn = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A2:N" & xdlgn).ClearContents
        .Range("A2").Resize(UBound(tblo1, 1), UBound(tblo1, 2)).Value = tblo1
        ' supprime les lignes vides
        xdlgn = .Range("A" & Rows.Count).End(xlUp).Row
        For i = xdlgn To 2 Step -1
          If .Cells(i, 1) = "" Then
           .Rows(i).Delete
          End If
        Next i
        .Range("A1").Select
          Application.ScreenUpdating = True
      End With
  Erase tblo: Erase tblo1
End Sub

Merci, par avance, pour votre aide

Rob's

[EngueEngue]

xdlgn ... faut lui donner une valeur