importer données excel par macro vba

Version imprimable

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:

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

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

1 pièce(s) jointe(s)

Bonjour,

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

Code:

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.

Bonjour et excusez moi du retard..Votre solution m'a résoud mon probleme et venu à mon secours..Merci

Citation:

Envoyé par EricDgn

Bonjour,

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

Code:

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.