VBA Correspondance De Colonnes

Version imprimable

11/09/2012, 00h28
tixilee

VBA Correspondance De Colonnes

Bonjour.

Sur ma feuille "DCE" se trouve une colonne intitulee "DCK" et remplie de texte.
Sur ma feuille "AFE" se trouve une colonne intitulee "AFK" et remplie de texte.

Pourriez-vous m'aider afin que sur une nouvelle feuille intitulee "REC":
- la colonne "DCK" de la feuille "DCE" soit copiee dans la colonne "A"
- la colonne "AFK" de la feuille "AFE" soit copiee dans la colonne "D"
- une colonne intitulee "AFM" soit creee dans la colonne "B"
- une colonne intitulee "DCM" soit creee dans la colonne "E"

Ensuite ma demande est dans la feuille "REC":
- pour chaque cellule remplie de la colonne "DCK",
retrouver la ligne dont le texte de la cellule est identique de la colonne "AFK" et recopier le numero de la ligne de la colonne "AFK" dans la colonne "AFM", sinon recoper "NOK".
- pour chaque cellule remplie de la colonne "AFK",
retrouver la ligne dont le texte de la cellule est identique de la colonne "DCK" et recopier le numero de la ligne de la colonne "DCK" dans la colonne "DCM", sinon recoper "NOK".

J'espere que c'est clair.

Merci beaucoup de votre aide!!! :mouarf::ccool::oops:

Bonjour,

Il faut s'y mettre. Avec l'enregistreur tu as déjà beaucoup de réponses. Voici un premier jet

Création de la nouvelle feuille avec copie de tes données

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
' Nouvelle feuille avec données
Sheets("DCE").Select
Range("a1").Select
ActiveCell.CurrentRegion.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("REC").Select
Range("A1").Select
ActiveSheet.Paste
 
Sheets("AFE").Select
Range("a1").Select
ActiveCell.CurrentRegion.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("REC").Select
Range("D1").Select
ActiveSheet.Paste

Création des nouvelles colonnes

Code:

1
2
3
4
5
' Nouvelles colonnes
Range("B1").Select
ActiveCell.Value = "AFM"
Range("e1").Select
ActiveCell.Value = "DCM"

Recherche des données

Code:

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
'Recherche valeur A dans colonne D
Range("a2").Activate
Do
    Dim Recherche As Range
    ref = ActiveCell.Value
    Set Recherche = Columns("d").Find(ref)
    If Not Recherche Is Nothing Then
        retour = Recherche.Address
    Else
        retour = "NOK"
    End If
    ActiveCell.Offset(rowoffset:=0, columnoffset:=1).Activate
    ActiveCell.Value = retour
    ActiveCell.Offset(rowoffset:=1, columnoffset:=-1).Activate
Loop Until ActiveCell.Value = ""
 
'Recherche valeur d dans colonne a
Range("d2").Activate
Do
    Dim Recherche2 As Range
    ref2 = ActiveCell.Value
    Set Recherche2 = Columns("a").Find(ref2)
    If Not Recherche2 Is Nothing Then
        retour2 = Recherche2.Address
    Else
        retour2 = "NOK"
    End If
    ActiveCell.Offset(rowoffset:=0, columnoffset:=1).Activate
    ActiveCell.Value = retour2
    ActiveCell.Offset(rowoffset:=1, columnoffset:=-1).Activate
Loop Until ActiveCell.Value = ""

A toi de modifier ce qui doit l'être.

11/09/2012, 11h21
Sogestion
Bonjour

Citation:

' Nouvelles colonnes
Range("B1").Select
ActiveCell.Value = "AFM"
Range("e1").Select
ActiveCell.Value = "DCM"

Pour mémoire il est conseillé d'éviter les Select/ActiveCell ..
Code:

1 2 3 Range("B1")= "AFM" Range("E1") = "DCM"
_____________
Cordialement

Bonjour,

En ce qui concerne la deuxieme partie de ta demande

Code:

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
 
Sub test()
 
Dim cpt_col_a As Integer, cpt_col_d As Integer
Dim derniereLigne_col_a As Integer, derniereLigne_col_d As Integer
 
 
derniereLigne_col_a = ActiveWorkbook.Sheets("REC").Range("a65536").End(xlUp).Row
derniereLigne_col_d = ActiveWorkbook.Sheets("REC").Range("d65536").End(xlUp).Row
 
'Insertion du texte "NOK" dans les cellules B et E
 
ActiveWorkbook.Sheets("REC").Range("B2").Select
ActiveCell.FormulaR1C1 = "NOK"
Selection.AutoFill Destination:=Range("B2:B" & derniereLigne_col_a)
 
ActiveWorkbook.Sheets("REC").Range("E2").Select
ActiveCell.FormulaR1C1 = "NOK"
Selection.AutoFill Destination:=Range("E2:E" & derniereLigne_col_d)
 
ActiveWorkbook.Sheets("REC").Range("B2").Select
 
For cpt_col_a = 2 To derniereLigne_col_a
    For cpt_col_d = 2 To derniereLigne_col_d
        If ActiveWorkbook.Sheets("REC").Range("a" & cpt_col_a) = ActiveWorkbook.Sheets("REC").Range("d" & cpt_col_d) Then
            ActiveWorkbook.Sheets("REC").Range("e" & cpt_col_d) = cpt_col_a
        End If
    Next cpt_col_d
Next cpt_col_a
 
For cpt_col_d = 2 To derniereLigne_col_d
    For cpt_col_a = 2 To derniereLigne_col_a
        If ActiveWorkbook.Sheets("REC").Range("a" & cpt_col_a) = ActiveWorkbook.Sheets("REC").Range("d" & cpt_col_d) Then
            ActiveWorkbook.Sheets("REC").Range("b" & cpt_col_a) = cpt_col_d
        End If
    Next cpt_col_a
Next cpt_col_d
 
 
 
MsgBox "Fin"
 
 
End Sub

13/09/2012, 00h02
tixilee

Bonjour.
Merci d'avoir repondu aussi rapidement!

La colonne "DCK" de la feuille "DCE" n'est pas la seule copiee dans la colonne "A" de la feuille "REC" mais toutes les autres colonne aussi.

Meme probleme avec la colonne "AFK" de la feuille "AFE" n'etant pas la seule colonne copiee dans la colonne "D" de la feuille "REC".

Donc, pour le moment, je suis incapable d'evaluer si la deuxieme partie du matching foncionnte.

Bonjour,

J'ai supposé que ce que tu appelles intitulé de colonne est un en-tête de colonne placé en ligne 1.

Code:

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
Option Explicit
Sub Test()
Dim Ws As Worksheet
Dim C As Range, Cel As Range
        Set Ws = Worksheets("REC")
        'On recherche la colonne avec l'en-tête "DCK" dans la feuille "DCE"
        Set C = Worksheets("DCE").Rows(1).Find("DCK", LookIn:=xlValues)
        'Si l'en-tête a été trouvée, la colonne "DCK" est copiee dans la colonne "A" dela feuille "REC"
        If Not C Is Nothing Then C.EntireColumn.Copy Destination:=Ws.Columns(1)
        'On recherche la colonne avec l'en-tête "AFK" dans la feuille "AFE"
        Set C = Worksheets("AFE").Rows(1).Find("AFK", LookIn:=xlValues)
        'Si l'en-tête a été trouvée, la colonne "AFK" est copiee dans la colonne "D" de la feuille "REC"
        If Not C Is Nothing Then C.EntireColumn.Copy Destination:=Ws.Columns(4)
        'une colonne intitulee "AFM" est creee dans la colonne "B"
        Ws.Range("B1") = "AFM"
        'une colonne intitulee "DCM" est creee dans la colonne "E"
        Ws.Range("E1") = "DCM"
        'Dans la feuille "REC", pour chaque cellule remplie de la colonne "DCK", on recherche la ligne dont le texte de la cellule _
        est identique de la colonne "AFK" et on recopie le numero de la ligne de la colonne "AFK" dans la colonne "AFM", _
        sinon on inscrit "NOK".
        Cherche Ws, 1, 4
        'Dans la feuille "REC", pour chaque cellule remplie de la colonne "AFK", on recherche la ligne dont le texte de la cellule _
        est identique de la colonne "DCK" et on recopie le numero de la ligne de la colonne "DCK" dans la colonne "DCM", _
        sinon on inscrit "NOK".
        Cherche Ws, 4, 1
End Sub
Sub Cherche(Sh As Worksheet, ColSource As Integer, ColCible As Integer)
Dim DerLig As Long
Dim firstAddress As String
Dim C As Range, Cel As Range
        DerLig = Sh.Cells(Sh.Rows.Count, ColSource).End(xlUp).Row
        For Each Cel In Sh.Range(Sh.Cells(2, ColSource), Sh.Cells(DerLig, ColSource))
            If Cel <> "" Then
                Set C = Sh.Columns(ColCible).Find(Cel, LookIn:=xlValues, lookat:=xlWhole)
                If Not C Is Nothing Then
                    firstAddress = C.Address
                    Do
                        Cel.Offset(0, 1) = C.Row
                        Set C = Sh.Columns(ColCible).FindNext(C)
                    Loop While Not C Is Nothing And C.Address <> firstAddress
                Else
                    Cel.Offset(0, 1) = "NOK"
                End If
            End If
        Next Cel
End Sub

Cordialement.

22/09/2012, 23h26
tixilee

Merci de vos reponses, encore une fois.
Vos commentaires m'ont aides a comprendre.

Un point bloquant est la copie des colonnes "AFK" & "DCK" sur la feuille "REC".
Sachant que ces deux colonnes sont des concatenates de plusieurs cellules, le resultat visuel est "#####".
Existerait-il une fonction Paste/Special/Values?

Bonjour,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
        'On recherche la colonne avec l'en-tête "DCK" dans la feuille "DCE"
        Set C = Worksheets("DCE").Rows(1).Find("DCK", LookIn:=xlValues)
        'Si l'en-tête a été trouvée, la colonne "DCK" est copiee
        If Not C Is Nothing Then C.EntireColumn.Copy
        'Les valeurs sont collées dans la colonne "A" de la feuille "REC"
        Ws.Columns(1).PasteSpecial xlPasteValues
 
        'On recherche la colonne avec l'en-tête "AFK" dans la feuille "AFE"
        Set C = Worksheets("AFE").Rows(1).Find("AFK", LookIn:=xlValues)
        'Si l'en-tête a été trouvée, la colonne "AFK" est copiee
        If Not C Is Nothing Then C.EntireColumn.Copy
        'Les valeurs sont collées dans la colonne "D" de la feuille "REC".
        Ws.Columns(4).PasteSpecial xlPasteValues

Cordialement.