Copier-Coller avec transposition en VBA

[TraceFinder]

Bonjour à tous,

Je souhaite réaliser des opérations de copier-coller avec transposition en utilisant le VBA.

Je joins un document exemple qui a globalement la même structure que mon document réel, mais en très simplifié. Ce document expose, en Feuil1 les résultats de mesures de paramètres quelconques (codés de A à E) avec leurs incertitudes associées.

J'aimerais pouvoir extraire, pour une ville donnée (qu'on renseignera à l'aide d'une boîte de dialogue au début, cette partie-là, c'est bon), ces données dans le tableau donné en Feuil2. Ainsi, si je m'intéresse à Lyon, je veux extraire les données des lignes 34 à 70. La structure des deux tableaux est différente, ce qui nécessite une transposition des données : en Feuil2, on aura la liste des paramètres dans la première colonne, puis les données correspondant à ce paramètre dans les colonnes suivantes (alors qu'elles sont toutes en colonnes en Feuil1).

Précision : J'ai mis 10 colonnes Données et 10 colonnes Incertitudes dans le tableau en Feuil2 car le nombre de mesures par paramètre peut varier, mais n'excède jamais 10.

Pour ce faire, j'avais imaginé deux pistes possibles :
- la 1ère : au moyen de boucles, on fixe un paramètre dans Feuil2, puis on parcourt Feuil1 à la recherche de données qui correspondent à la bonne ville et au bon paramètre et on extrait ces données dans Feuil2
- la 2ème : on fixe un paramètre dans Feuil2, puis on parcourt Feuil1 à la recherche de données qui correspondent à la bonne ville et au bon paramètre, on sélectionne ces données et on les copie-colle en les transposant dans Feuil2.

Je suis encore novice en VBA, j'ai beau essayer, je n'arrive pas à obtenir ce que je veux. Aussi, si quelqu'un pouvait m'aider, ça serait sympa.

 

[gilbert_RGI]

Re : Copier-Coller avec transposition en VBA

Bonjour,

voir feuille2 et 3 mes possibilités

 

[TraceFinder]

Re : Copier-Coller avec transposition en VBA

Merci Gilbert, j'étais justement en train d'écrire que j'avais trouvé une solution par moi-même. A côté de ce que tu as écrit, c'est peut-être un peu brouillon, mais au moins ça fait le job Quoi qu'il en soit tes idées devraient me servir par la suite

 

[klin89]

Re : Copier-Coller avec transposition en VBA

Bonjour TraceFinder, gilbert_RGI, le forum

Comme j'ai compris :
Résultat à côté du tableau original.

Option Explicit

Sub transpose()
Dim a, i As Long, j As Long, maxCol As Long, dico As Object, txt As String
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1").Range("a1").CurrentRegion
        a = .Value
        With dico
            For i = 1 To UBound(a, 1)
                txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
                If Not .exists(txt) Then
                    Set .Item(txt) = CreateObject("Scripting.Dictionary")
                End If
                .Item(txt)(.Item(txt).Count) = VBA.Array(a(i, 3), a(i, 4))
                maxCol = Application.Max(maxCol, .Item(txt).Count)
            Next
            ReDim a(1 To .Count, 1 To maxCol * 2 + 2)
            For i = 0 To .Count - 1
                a(i + 1, 1) = Split(.keys()(i), Chr(2))(0)
                a(i + 1, 2) = Split(.keys()(i), Chr(2))(1)
                For j = 0 To .items()(i).Count - 1
                    a(i + 1, j + 3) = .items()(i).items()(j)(0)
                    a(i + 1, j + 3 + maxCol) = .items()(i).items()(j)(1)
                Next
            Next
        End With
        Application.ScreenUpdating = False
        With .Offset(, .Columns.Count + 2).Resize(dico.Count, maxCol * 2 + 2)
            .CurrentRegion.Clear
            .Value = a
            With .CurrentRegion
                .Font.Name = "calibri"
                .Font.Size = 10
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                With .Rows(1)
                    .Font.Size = 11
                    .Interior.ColorIndex = 43
                    .BorderAround Weight:=xlThin
                End With
                With .Cells(1, 3)
                    .Value = .Value & " 1"
                    If maxCol > 1 Then
                        .AutoFill .Resize(, maxCol)
                    End If
                    .Resize(, maxCol).Interior.ColorIndex = 6
                End With
                With .Cells(1, maxCol + 3)
                    .Value = .Value & " 1"
                    If maxCol > 1 Then
                        .AutoFill .Resize(, maxCol)
                    End If
                    .Resize(, maxCol).Interior.ColorIndex = 40
                End With
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89