Table correspondance sur plusieurs feuilles

Le 23/10/2018 à 10:38

Bonjour à toutes et tous

En mettant en place vos conseils et solutions du post ci après j'ai pu créer une table de correspondance qui corrige certaines valeurs d'une feuille précise.

https://forum.excel-pratique.com/viewtopic.php?f=2&t=85137

Je cherche à adapter les codes ci après pour que la table soit valable non pas uniquement sur une seule feuille précise mais sur toutes les feuilles du classeur à l'exclusion de certaines (des boucles imbriquées)

code fonctionnelle sur une feuille précise :

Sub CorrespondanceCol()

    Dim d As New Collection, n%, i%
    With Worksheets("TABLE")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            d.Add .Cells(i, 2), CStr(.Cells(i, 1))
        Next i
    End With
    With Worksheets("BASE TRAITEE MACRO")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        For i = 2 To n
            .Cells(i, 1) = d(CStr(.Cells(i, 1)))
        Next i
    End With

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
Sub Correspondance()

    Dim Cold(), Cnew(), n%, i%, j%
    With Worksheets("TABLE")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        ReDim Cold(1 To n - 1): ReDim Cnew(1 To n - 1)
        For i = 2 To n
            Cold(i - 1) = .Cells(i, 1)
            Cnew(i - 1) = .Cells(i, 2)
        Next i
    End With
    With Worksheets("BASE TRAITEE MACRO")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        For i = 2 To n
            j = WorksheetFunction.Match(.Cells(i, 1), Cold, 0)
            If Err.Number = 0 Then
                .Cells(i, 1) = Cnew(j)
            Else
                Err.Clear
            End If
        Next i
        .Activate
    End With
End Sub

En m'inspirant d'autre éléments que vous m'avez déjà proposé j'ai essayé mais sans succès d'adapter ces 2 codes sur la base ci après, pourriez vous m'aider a finaliser mon approche. Je joins un classeur exemple.

Merci

Cordialement

Hugues

Sub CorresondanceColbis()

Dim d As New Collection, n%, i%
    With Worksheets("TABLE")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            d.Add .Cells(i, 2), CStr(.Cells(i, 1))
        Next i
    End With

For Each sh In Worksheets
      Select Case sh.Name
         Case "A ECARTER 01", "A ECARTER 01", "BASE EXEMPLE avant macro", "TABLE"
         Case Else

        n = sh.Cells(.Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        For i = 2 To n
            sh.Cells(i, 1) = d(CStr(sh.Cells(i, 1)))
        Next i

End Select
   Next sh

End Sub
Sub Correspondancebis()

    Dim Cold(), Cnew(), n%, i%, j%
    With Worksheets("TABLE")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        ReDim Cold(1 To n - 1): ReDim Cnew(1 To n - 1)
        For i = 2 To n
            Cold(i - 1) = .Cells(i, 1)
            Cnew(i - 1) = .Cells(i, 2)
        Next i
    End With

    For Each sh In Worksheets
      Select Case sh.Name
         Case "A ECARTER 01", "A ECARTER 01", "BASE EXEMPLE avant macro", "TABLE"
         Case Else

        n = sh.Cells(.Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        For i = 2 To n
            j = WorksheetFunction.Match(sh.Cells(i, 1), Cold, 0)
            If Err.Number = 0 Then
                sh.Cells(i, 1) = Cnew(j)
            Else
                Err.Clear
            End If
        Next i
        sh.Activate
    Next sh

End Sub
6table-correspondance-v01.xlsm (24.45 Ko)
Le 23/10/2018 à 15:02

Bonjour,

J'ai tenté de corrigé des défauts de programmation en mode déboguage sur tes différents programmes :

Corresondancecolbis:
Sub CorresondanceColbis()

Dim d As New Collection, n%, i%
    With Worksheets("TABLE")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            d.Add .Cells(i, 2), CStr(.Cells(i, 1))
        Next i
    End With

For Each sh In Worksheets
    Select Case sh.Name
        Case "A ECARTER 01", "A ECARTER 01", "BASE EXEMPLE avant macro", "TABLE"
        Case Else

        n = sh.Cells(Rows.Count, 1).End(xlUp).Row 'référence incorrecte ou non qualifiée sur .rows
        'remplacé par Rows, tu n'as pas fait de with pour ton .rows j'utilise la feuille active

        On Error Resume Next
        For i = 2 To n
            sh.Cells(i, 1) = d(CStr(sh.Cells(i, 1)))
        Next i

    End Select
Next sh

End Sub
Correspondancebis:


Sub Correspondancebis()

    Dim Cold(), Cnew(), n%, i%, j%
    With Worksheets("TABLE")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        ReDim Cold(1 To n - 1): ReDim Cnew(1 To n - 1)
        For i = 2 To n
            Cold(i - 1) = .Cells(i, 1)
            Cnew(i - 1) = .Cells(i, 2)
        Next i
    End With

    For Each sh In Worksheets
      Select Case sh.Name
         Case "A ECARTER 01", "A ECARTER 01", "BASE EXEMPLE avant macro", "TABLE"
         Case Else

            n = sh.Cells(Rows.Count, 1).End(xlUp).Row 'référence incorrecte ou non qualifiée sur .rows
            'remplacé par Rows, tu n'as pas fait de with pour ton .rows j'utilise la feuille active
            On Error Resume Next
            For i = 2 To n
                j = WorksheetFunction.Match(sh.Cells(i, 1), Cold, 0)
                If Err.Number = 0 Then
                    sh.Cells(i, 1) = Cnew(j)
                Else
                    Err.Clear
                End If
            Next i
            sh.Activate
        End Select
    Next sh 'next sans for, dû au fait que tu n'aies pas de end select, tu n'avais pas tabulé après ton end select,
    'tu ne pouvais pas voir qu'il était manquant

End Sub

Je ne rencontre plus de bug en lançant ton programme avec ces corrections, j'espère que ça suffira, je te laisse faire le reste des tests

Le 23/10/2018 à 17:39

Bonjour Ausecour,

Un grand merci un grand bravo

Solutions et explications à mes erreurs et très rapidement

Très cordialement

Hugues

Rechercher des sujets similaires à "table correspondance feuilles"