Application match

[manuBX]

Bonjour
a partir de ce fichier exemple
peut on m indiquer l utilisation de " application match "

il s agit de copier dans feuil1 sous D1 qui est une date l équivalent de la feuil2 sous la date corespondant
si je change D1 la recherche se fait pour trouver la date et copier ce qui est dessous
si la date n existe pas inscrire "pas date"

merci d avance

 

[youky(BJ)]

Re : Application match

Bonjour,
Voici qui doit faire l'affaire.
J'ai supprimé le module et mis la macro en worksheet_change
c'est direct au changement de D1
Bruno

 

[manuBX]

Re : Application match

MERCI
Mais il me faudrait qu il copie la totalité du contenu des cellules y compris les couleurs
A+

 

[kjin]

Re : Application match

Bonjour,

Sub test()
Dim x, c As Range
With [Feuil2]
    On Error GoTo fin
    x = Application.Match([D1], .[E14:N14], 0) + 4
        Set c = .Range(.Cells(15, x), .Cells(65000, x).End(xlUp))
        c.Copy Range("D2")
    Exit Sub
End With
fin:
Range("D2") = "Pas de date"
End Sub

A+
kjin

 

[manuBX]

Re : Application match

Merci
mais il ne copie que une cellule de couleurs et pas la colonne entière ?
A+

 

[kjin]

Re : Application match

Bonsoir,

Merci
mais il ne copie que une cellule de couleurs et pas la colonne entière ?
A+

primo chez moi on dit bonjour
deusio on indique à qui on s'adresse
ceci étant dit, si la question m'était adressée, je répondrais que je me suis basé sur le fichier fourni et comme je ne suis pas devin..., toujours est-il que chez moi ça fonctionne, si ce n'est qu'il n'y a pas la couleur et pour cause, tu cherches le 02/09/2011 ce qui correspond à la colonne G qui ne comporte aucune cellule colorée !
A+
kjin

 

[manuBX]

Re : Application match

Bonsoir
Kjin et Youky
Excusez moi si j ai été un peu trop "Speed"(incorrect )
les 2 solutions fonctionnent mais (dommage ) partiellement par rapport à mes besoins
en effet en modifiant D1 feuil1 il faudrait qu il s inscrive dessous la valeur équivalent de feuil2 sous E14 N14 y compris les couleurs les valeurs numériques et textes
Merci d avance
A+

 

[kjin]

Re : Application match

Bonsoir,
J'ai réadapté par une macro événementielle

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x, c As Range
If Target.Address = "$D$1" And Target.Count = 1 Then
    [D2:D500].Clear
    If Not IsEmpty(Target) Then
        With [Feuil2]
            On Error GoTo fin
            x = Application.Match([D1], .[E14:N14], 0) + 4
                Set c = .Range(.Cells(15, x), .Cells(65000, x).End(xlUp))
                c.Copy Range("D2")
        End With
    End If
End If
Exit Sub

fin:
    Range("D2") = "Pas de date"
End Sub

A+
kjin

 

[manuBX]

Re : Application match

Bonsoir
il doit y avoir un problème de cellule vide car si je met en D2 "02/01/12" il met uniquement la premiere cellule verte et pas les autres

A+

 

[Si...]

Re : Application match

salut

Match nul 😉, avec Find :

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim C As Range
    If Target.Address = "$D$1" And Target.Count = 1 Then
        [D2:D500].Clear '500, comme ci-après, arbitraire
        With [Feuil2]
            Set C = .Range("E14:N14").Find(CDate(Target))
            If C Is Nothing Then
                Range("D2") = "Pas de date"
            Else
                .Range(.Cells(15, C.Column), .Cells(500, C.Column)).Copy Range("D2")
            End If
        End With
    End If
End Sub

 

[manuBX]

Re : Application match

Bonjour à tous et merci
j ai testé avec find ça fonctionne MERCI
Mais pour des raisons X Y Z je dois changer l emplacement des dates en feuil2 et elles se retouvent en verticale c est à dire en D4D30 au lieu de E14N14
donc cette partie ne peut plus fonctionner
With [Feuil2]
Set C = .Range("E14:N14").Find(CDate(Target))
If C Is Nothing Then
Range("D2") = "Pas de date"
Else
.Range(.Cells(15, C.Column), .Cells(500, C.Column)).Copy Range("D2")
End If
End With
End If
il s agit de copier et de transposer
est ce possible ?
Merci d avance
A+

 

[Paritec]

Re : Application match

Bonjour Tous,
oui bien sur que c'est possible
a+
papou🙂

 

[kjin]

Re : Application match

Bonjour, salut Papou,

Match nul 😉, avec Find :

Je préfère cette solution là aussi, mais tout comme Youky, que je salue, je me suis contenté de répondre à la question

il doit y avoir un problème de cellule vide car si je met en D2 "02/01/12" il met uniquement la premiere cellule verte et pas les autres

Je n'avais pas compris que les cellules sans données mais colorées devaient être également copiées.
De plus, trouver la dernière cellule colorée risque d'être fastidieux et on ne sait pas si la couleur est appliquées manuellement ou par MFC, à moins qu'il y ait une autre explication mais là il faut être devin

Mais pour des raisons X Y Z je dois changer l emplacement des dates en feuil2 et elles se retouvent en verticale c est à dire en D4D30 au lieu de E14N14
donc cette partie ne peut plus fonctionner

N'as tu donc pas tenté de comprendre ?!
Les 2 solutions réadaptées :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x
If Target.Address = "$D$1" And Target.Count = 1 Then
    [D2:D500].Clear '500 arbitraire
    If Not IsEmpty(Target) Then
        With [Feuil2]
            On Error GoTo fin
            x = Application.Match([D1], .Columns(4), 0)
                .Range(.Cells(x, 5), .Cells(x, 100)).Copy '100 arbitraire
                Range("D2").PasteSpecial Transpose:=True
                Application.CutCopyMode = False
                [D2].Select
        End With
    End If
End If
Exit Sub

fin:
    Range("D2") = "Pas de date"
End Sub

ou

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    If Target.Address = "$D$1" And Target.Count = 1 Then
        [D2:D500].Clear '500 arbitraire
        With [Feuil2]
            Set c = .Columns(4).Find(CDate(Target))
            If c Is Nothing Then
                Range("D2") = "Pas de date"
            Else
                .Range(.Cells(c.Row, 5), .Cells(c.Row, 100)).Copy '100 arbitraire
                Range("D2").PasteSpecial Transpose:=True
                Application.CutCopyMode = False
                [D2].Select
            End If
        End With
    End If
End Sub

A+
kjin

 

[Si...]

Re : Application match

re

à tester :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim C As Range, N As Byte
    If Target.Address = "$D$1" And Target.Count = 1 Then
        [D2:D50].Clear '500, comme ci-après, arbitraire
        With [Feuil2]
            Set C = .Range("D14:D30").Find(CDate(Target))
            If C Is Nothing Then
                Range("D2") = "Pas de date"
            Else
                For N = 8 To 50
                  .Cells(C.Row, N).Copy Cells(N - 6, "D")
                Next
            End If
        End With
    End If
End Sub

salut kjin

 

[manuBX]

Re : Application match

Merci à tous
cela fonctionne
j avais bien essayé de le comprendre pour le modifie mais je bloqais sur la ligne
x = Application.Match([D1], .Columns(4), 0)
.Range(.Cells(x, 5), .Cells(x, 100)).Copy
ou
.Range(.Cells(15, C.Column), .Cells(500, C.Column)).Copy Range("D2")
ENCORE UNE FOIS MERCI