Discussion :

[cajo jim]

Bonjour à tous .. s'il vous plait aidez moi pour mon probleme qui est le suivant : sur la feuille1, colonne A de données Excel,(environ 7000 cellules), j'aime bien que vous m'aidez à trouver une macro vba qui détecte Les valeurs X, dans les autres feuilles du dossier Excel (feuille 2...3...4...), copie les trois cellules consécutives, trouvées et les colle à coté de la colonne A et ceci quand valeur de X = A1 de façon à avoir:

Colonne A	colonne B	colonne C	colonne D
A1	X	Y	Z
A2
A3

X est la valeur cherchée ET égale à valeur de A1

Y, Z les cellules consécutives à X.

Ne pas supprimer les doublons
j'ai trouvé la macro suivante mais qui demande des amelioratins: Sub compare()

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
Dim cell_testA As Range
Dim cell_testB As Range
 
With Worksheets("Feuil2")
    Set cell_testA = .Range("A1")
    Set cell_testB = Worksheets("Feuil3").Range("B1")
    For i = 0 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row - 1
        For j = 0 To Worksheets("Feuil3").Columns(2).Find("*", , , , xlByColumns, xlPrevious).Row - 1
            If cell_testA.Offset(i, 0) = cell_testB.Offset(j, 0) Then
                For k = 1 To 3
                    cell_testA.Offset(i, k) = cell_testB.Offset(j, k)
                Next k
            End If
        Next j
    Next i
End With
 
End Sub

Je vous remercie de vous m'aidez à résoudre ce problème et m'évite de faire à la main des milliers de fois de copier coller et rechercher. Merci

[EricDgn]

Bonjour,

Je ne suis pas certain d'avoir bien compris votre demande mais voici toujours quelque chose qui doit s'en approcher:

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
Option Explicit
 
Sub ChercherCopier()
    Dim c As Range, wSh As Worksheet, r As Range
    Set c = Range("A2")
    While c.Value <> ""
        For Each wSh In Worksheets
            If wSh.Name <> ActiveSheet.Name Then
                Set r = wSh.UsedRange.Find(What:=c.Value, After:=wSh.UsedRange.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If Not r Is Nothing Then Exit For
            End If
        Next wSh
        If Not r Is Nothing Then
            c.Offset(0, 1).Value = c.Value
            c.Offset(0, 2).Value = r.Offset(0, 1).Value
            c.Offset(0, 3).Value = r.Offset(0, 2).Value
        End If
        Set c = c.Offset(1, 0)
    Wend
    Set c = Nothing
    Set r = Nothing
    MsgBox "Terminé", , "Pour info"
End Sub

Note: la recherche s'arrête dès que la valeur a été trouvée, ne regarde pas s'il y a plusieurs fois la même valeur.

Cordialement.

[cajo jim]

Bonjour,

Je ne suis pas certain d'avoir bien compris votre demande mais voici toujours quelque chose qui doit s'en approcher:

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
Option Explicit
 
Sub ChercherCopier()
    Dim c As Range, wSh As Worksheet, r As Range
    Set c = Range("A2")
    While c.Value <> ""
        For Each wSh In Worksheets
            If wSh.Name <> ActiveSheet.Name Then
                Set r = wSh.UsedRange.Find(What:=c.Value, After:=wSh.UsedRange.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If Not r Is Nothing Then Exit For
            End If
        Next wSh
        If Not r Is Nothing Then
            c.Offset(0, 1).Value = c.Value
            c.Offset(0, 2).Value = r.Offset(0, 1).Value
            c.Offset(0, 3).Value = r.Offset(0, 2).Value
        End If
        Set c = c.Offset(1, 0)
    Wend
    Set c = Nothing
    Set r = Nothing
    MsgBox "Terminé", , "Pour info"
End Sub

Note: la recherche s'arrête dès que la valeur a été trouvée, ne regarde pas s'il y a plusieurs fois la même valeur.

Cordialement.