Compilation plusieurs classeurs et onglets

[jobicopa]

Bonjour le forum,

Je reviens une nouvelle fois vers vous car je suis bloqué. Je cherche à réaliser un fichier qui compilera les données de nos fournisseurs suite à une demande de prix sur des référence.

Dans l'exemple joint, j'ai deux classeurs, le premier "Fournisseur test" où j'ai renseigner des valeurs pour essayer.

Et un classeur "CompilationXLD" où on retrouve l'onglet "Acceuil" expliquant brièvement mes attentes, l'onglet "Fichiers_sources" qui contient le chemin d'accès pour y accéder (à modifier pour vous afin qu'il aille directement le chercher au bon endroit). Et enfin un dernier onglet "Marque1" qui sera l'endroit où les informations seront synthétisées.

Mon code ne marche pas à un endroit et je n'arrive pas du tout à comprendre ce qui ne va pas.

Private Sub Compilateur_Click()
Dim sources As Variant
Dim Fourn As Integer
Dim Onglet As Integer
Dim Feuille As Integer
Dim o As Integer
Dim DerniereColonne As Integer
Dim DernierOnglet As Integer
Dim DerniereLigneComp As Integer
Dim FournOk, OngletOk As Integer
Dim WbComp As Workbook
Dim WbFrs As Workbook
Dim WbFrsOk As Workbook
Dim RefFrs As Integer
Dim RefComp As Range
Dim Test As Integer
Dim ref As String
Dim r As Range
Dim TrouveRef As Integer
Dim FsOk As Object
Dim NomClasseurOk As String
Dim lastrow As Integer

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim lok As Integer
Dim c As Range


[COLOR="Green"]'Première étape : Mise en place[/COLOR]

Application.ScreenUpdating = False

Set WbComp = ThisWorkbook
ActiveWorkbook.Worksheets("Fichiers_sources").Select

sources = WbComp.Worksheets("Fichiers_sources").Range("A1").CurrentRegion

DernierOnglet = Range("IV2").End(xlToLeft).Column

[COLOR="green"]'Deuxième étape : Validation des données et fichiers (vérification qu'ils sont existant et chemin accès)[/COLOR]

 For Fourn = 2 To UBound(sources, 1)
    
        If Not IsEmpty(sources(Fourn, 1)) Then
               
            Workbooks.Open FileName:=sources(Fourn, 1)
                
            Set WbFrs = ActiveWorkbook
                
                For Onglet = 3 To DernierOnglet
          
                    WbComp.Activate
                    Worksheets(sources(Fourn, Onglet)).Activate
                    DerniereColonne = Range("IV1").End(xlToLeft).Column + 1
        
                
                         For Feuille = 1 To Sheets.Count
                
                            If Worksheets(Feuille).Name = sources(Fourn, Onglet) Then
                        
                                Feuille = 1
                                Exit For
                                 
                            Else
                    
                                MsgBox "L'onglet " & sources(Fourn, Onglet) & " n'existe pas dans ce fichier fournisseur", vbCritical
                    
                                Exit Sub
                    
                            End If
                
                        Next Feuille
                Next Onglet
    End If

Next Fourn

[COLOR="green"]'Troisième étape : Ajout des nouvelles références issues des fichiers fournisseurs et colorisation
'Vert s'il y a eu copie
'Bleu s'il y a eu ajout
'Rouge s'il n'y a rien eu, cad si la référence n existait pas che le fournisseur[/COLOR]

For FournOk = 2 To UBound(sources, 1)
   
    Set FsOk = CreateObject("Scripting.FileSystemObject")
    NomClasseurOk = FsOk.GetFile(sources(FournOk, 1)).Name
    Windows(NomClasseurOk).Activate
    Set WbFrsOk = ActiveWorkbook
    
         For OngletOk = 3 To DernierOnglet
    
        
            For i = 2 To WbFrsOk.Worksheets(sources(FournOk, OngletOk)).Range("A65536").End(xlUp).Row
            ref = WbFrsOk.Worksheets(sources(FournOk, OngletOk)).Cells(i, 1).Value
    
            Set c = WbComp.Worksheets(sources(FournOk, OngletOk)).Range("A2:A" & WbComp.Worksheets("Marque1").Range("A65536").End(xlUp).Row).Find("*" & ref & "*", LookIn:=xlValues)
                If Not c Is Nothing Then
                lok = c.Row
    
[COLOR="green"]'C'est ici que ca coince
'Erreur définie par l'application ou par l'objet ...[/COLOR]

                WbComp.Worksheets(sources(FournOk, OngletOk)).Range(Cells(lok, 3), Cells(lok, 5)).Interior.Color = RGB(0, 255, 0)
                WbComp.Worksheets(sources(FournOk, OngletOk)).Range(Cells(lok, 3), Cells(lok, 5)).Value = WbFrsOk.Worksheets(sources(FournOk, OngletOk)).Range(Cells(i, 3), Cells(i, 5)).Value
    
    
                Else
    
                k = WbComp.Worksheets(sources(FournOk, OngletOk)).Range("A65536").End(xlUp).Row
    
                WbComp.Worksheets(sources(FournOk, OngletOk)).Range(Cells(k, 1), Cells(k, 5)).Value = WbFrs.Worksheets(sources(FournOk, OngletOk)).Range(Cells(i, 1), Cells(i, 5)).Value
    
                End If
   
            Next i

            For j = 2 To WbComp.Worksheets(sources(FournOk, OngletOk)).Range("A65536").End(xlUp).Row

                If WbComp.Worksheets(sources(FournOk, OngletOk)).Cells(j, 3).Interior.Color = RGB(255, 255, 255) Then
                WbComp.Worksheets(sources(FournOk, OngletOk)).Range(Cells(j, 3), Cells(j, 5)).Interior.Color = RGB(255, 0, 0)
                End If
            Next j
        
        Next OngletOk

WbFrs.Close
Next FournOk

Application.ScreenUpdating = True

End Sub

Voilà mon souci (ca fait déjà un moment que je suis dessus). En espérant avoir été clair. Je suis dispo pour tout renseignement complémentaire.

Merci d'avance à ceux qui se pencheraient sur mon problème.

Cijoint.fr - Service gratuit de dépôt de fichiers

 

[Bebere]

Re : Compilation plusieurs classeurs et onglets

bonjour Jobicopa
vois si cela te convient

Private Sub Compilateur()
Dim sources As Variant
Dim Fourn As Integer, l As Integer
Dim Onglet As Integer
Dim DernierOnglet As Integer
Dim Ref
Dim MyWs As Worksheet
Dim k As Integer
Dim lok As Integer
Dim c As Byte, TblFournisseur
Dim Cel As Range

'Première étape : Mise en place

Application.ScreenUpdating = False

Set MyWs = ThisWorkbook.Worksheets("Marque1")
'Ref = MyWs.Range("A2:A" & MyWs.Cells(65356, 1).End(xlUp).Row)

With ThisWorkbook.Worksheets("Fichiers_sources")
sources = .Range(.Cells(2, 1), .Cells(.Cells(65356, 1).End(xlUp).Row, .Cells(1, 256).End(xlToLeft).Column))
End With
DernierOnglet = UBound(sources, 2)

'Deuxième étape : Validation des données et fichiers (vérification qu'ils sont existant et chemin accès)

For Fourn = 1 To UBound(sources, 1)


For Onglet = 4 To DernierOnglet
If Not IsEmpty(sources(Fourn, 1)) Then

Workbooks.Open FileName:=sources(Fourn, 1) & sources(Fourn, 2)
TblFournisseur = ActiveWorkbook.Worksheets(CStr(sources(Fourn, Onglet))).UsedRange
ActiveWorkbook.Close
'For i = 1 To UBound(Ref, 1)
For l = 2 To UBound(TblFournisseur, 1)
Ref = TblFournisseur(l, 1): lok = 0
Set Cel = MyWs.Columns("A").Find(Ref, LookIn:=xlValues)
If Not Cel Is Nothing Then
lok = Cel.Row
With MyWs
For c = 2 To UBound(TblFournisseur, 2)
.Cells(lok, c) = TblFournisseur(l, c)
.Cells(lok, c).Interior.ColorIndex = 35
Next c
End With

Else


With MyWs
k = .Range("A65536").End(xlUp).Row + 1
For c = 1 To UBound(TblFournisseur, 2)
.Cells(k, c) = TblFournisseur(l, c)
.Cells(k, c).Interior.ColorIndex = 20
Next c
End With
End If


Next l
End If
Next Onglet
Next Fourn

With MyWs
For c = 1 To UBound(TblFournisseur, 2)
If .Cells(1, c) = "" Then .Cells(1, c) = TblFournisseur(1, c)
Next c
For Each Cel In .Range(.Cells(2, 2), .Cells(.Cells(65356, 2).End(xlUp).Row, 2))
If Cel.Interior.ColorIndex = -4142 Then Cel.Interior.ColorIndex = 46 'rouge
Next Cel
End With

'
Application.ScreenUpdating = True

End Sub

à bientôt