XL 2016 VBA Copier coller selon plusieurs critères

youklebambou

XLDnaute Junior
Bonjour,
Je bute sur un problème, je souhaiterais copier les cellules d'une colonnes en fonction de la dates sur la ligne du haut et des numéros sur la colonne A.... J'avais réussi a faire un copier coller en fonction de la date mais ça ne triait pas en fonction de la colonne A....



si quelqu'un a la solution ;-) merci
 

Pièces jointes

  • Test.xlsm
    16.9 KB · Affichages: 28

jp14

XLDnaute Barbatruc
Bonsoir
Ci dessous une macro qui devrait répondre au problème


Code:
Option Explicit
Dim Col As String, Lig As Long
Sub Copiecommande()
Dim CelluleO As Range, CelluleD As Range, CelluleOL As Range, CelluleDL As Range
Dim LiDateO As Range, LiDateD As Range, RefO As Range, RefD As Range
Dim Trouve As Byte, ColO As String, ColD As String, Ligo As Long, LigD As Long
Dim ColonneAO As Range, ColonneAD As Range

'parametre a modifier en fonction des données
With Sheets(ActiveSheet.Name)
    'ligne
    Set LiDateO = .Range(.Cells(3, 4), .Cells(3, .Cells(3, Rows(3).Cells.Count).End(xlToLeft).Column))
    'colonne
    Set ColonneAO = .Range("A4:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With

With Sheets("destination")
    'ligne
    Set LiDateD = .Range(.Cells(1, 2), .Cells(1, .Cells(1, Rows(31).Cells.Count).End(xlToLeft).Column))
    'colonne
    Set ColonneAD = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)

'Recherche des lignes et colonnes

For Each CelluleO In LiDateO
    If CelluleO = "" Then Exit Sub
    If Not IsDate(CelluleO) Then
        Call MsgBox(CelluleO & ": n'est pas une date valide jj/mm/aaaa" _
                    & vbCrLf & "" _
                    & vbCrLf & "" _
                    , vbCritical, "Erreur")
        Exit Sub
    End If
    ' recherche des colonnes
    Recherchecolonne LiDateD, CelluleO.Value
    If Col <> "" Then
        ColD = Col
        ColO = Replace(CelluleO.Address, CelluleO.Row, "")
        ColO = Replace(ColO, "$", "")
    End If
  
    If ColD <> "" Then ' on a trouvé une colonne on recherche la igne
        For Each CelluleOL In ColonneAO
            If IsNumeric(CelluleOL.Value) Then
                Recherchecolonne ColonneAD, CelluleOL.Value
                LigD = Lig
                Ligo = CelluleOL.Row
            End If

            'lignes colonnes
            If LigD > 0 And ColD <> "" Then
                .Range(ColD & LigD) = Sheets(ActiveSheet.Name).Range(ColO & Ligo)
            End If

        Next CelluleOL
    End If
Next CelluleO

End With
End Sub


Private Sub Recherchecolonne(Plage1 As Range, Valeur1 As String)
Dim Cellule As Range
Col = "": Lig = 0
For Each Cellule In Plage1
    If CStr(Cellule) = Valeur1 Then
        Col = Replace(Cellule.Address, Cellule.Row, "")
        Col = Replace(Col, "$", "")
        Lig = Cellule.Row
        Exit For
    End If
Next Cellule
End Sub

A tester

JP
 

Discussions similaires

Réponses
15
Affichages
425
Réponses
6
Affichages
362