Macro copier coller

Bonjour tout le monde,

Je cherche à réaliser une macro VBA permettant de faire le suivant:

* partir des données de la feuille ''données initiales" (voir fichier Excel attaché)

* recopier les données ''charge de sinistres'' dans la feuille "objectif final"

* avec la première ligne est les années de survenance : par exemple pour année de survenance '1' signifie pour année d'inventaire 2005 année de survenance 2005, 2 année de survenance 2006 et 3 année de survenance 2007 et ainsi de suite... pour pour année de survenance '1' signifie pour année d'inventaire 2006 année de survenance 2006, 2 année de survenance 2007 et 3 année de survenance 2008..

Merci et bonne journée

18exemple.xlsx (11.70 Ko)

Up

Bonjour le forum,

Une solution sans macro à tester !

8macro-copier.xlsx (14.37 Ko)

C'est exactement ce que je cherche mais obligatoirement avec une macro !

Est ce possible?


Up

up

Bonjour à tous,

Vois ceci :

Option Explicit
Sub ventile()
Dim a, i As Long, j As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Données Initiales").[b1].CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 2)) Then
            Set dico(a(i, 2)) = CreateObject("Scripting.Dictionary")
            'dico(a(i, 2)).CompareMode = 1
        End If
        dico(a(i, 2))(a(i, 1)) = a(i, 3)
    Next
    Application.ScreenUpdating = False
    With Sheets("objectif final").[b1].CurrentRegion
        With .Offset(2, 2).Resize(.Rows.Count - 2, .Columns.Count - 2)
            .ClearContents
            .NumberFormat = " #,##0"
        End With
        For i = 3 To .Rows.Count
            If dico.exists(.Cells(i, 2).Value) Then
                For j = 3 To .Columns.Count
                    If dico(.Cells(i, 2).Value).exists(.Cells(2, j).Value) Then
                        .Cells(i, j).Value = dico(.Cells(i, 2).Value)(.Cells(2, j).Value)
                    End If
                Next
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

On pourrait aussi utiliser Application.Match

klin89

Urgence disiez-vous ? (dans le titre du message et 2 "Up" ...)

Visiblement l'urgence n'existe pas pour le retour d'informations.... quant aux remerciements......

Pour ma part, si vous deviez exposer un autre besoin, il y aurait urgence à ne pas vous répondre... !

Rechercher des sujets similaires à "macro copier coller"