MACRO/Transposer pour retraitement base de données à plat

[ador_matt]

Bonjour à tous,

J'ai besoin de votre aide afin de pouvoir réaliser un traitement de base de données dans le but de créer un fichier "à plat" qui puisse être intégré/uploadé dans un système.

Il y a probablement une astuce VBA, mais je ne suis pas vraiment experte en la matière et je ne trouve pas de solution à en utilisant un TCD.

Ci-joint un exemple simplifié avec une vision avant/après réalisée manuellement.
Compte tenu du nombre réel de lignes à retraiter je suis preneuse de tout solution automatisée!

Merci!!

 

[phlaurent55]

Re : MACRO/Transposer pour retraitement base de données à plat

Bonjour ador_matt,

voir fichier joint

à+
Philippe

 

[ador_matt]

Re : MACRO/Transposer pour retraitement base de données à plat

Bonjour Philippe,

A priori ça m'a l'air juste parfait!
Je vais me creuser un peu la tête pour comprendre le fonctionnement et réaliser l'adaptation à plus grande échelle.

Merci beaucoup et bonne journée!

Mathilda

 

[ador_matt]

Re : MACRO/Transposer pour retraitement base de données à plat

Philippe,

Il y a encore une chose qui m'échappe.

Sur la partie:

If Cells(i, j) <> "" Then
Cells(derligne, 2) = Cells(i, 2)
Cells(derligne, 3) = Cells(2, j)
Cells(derligne, 4) = Cells(i, j)

J'ai compris que cela permet de passer à la cellule suivante si celle-ci est vide et cela jusqu'à 3 cellules vides.
Si je veux ajouter la variable d'une 4ieme cellule vide (dans le cas d'un concurrent #4 dans mon exemple) dois-je uniquement ajouter la ligne suivante :

Cells(derligne, 5) = Cells(i, j)

Merci d'avance pour tes explications!

 

[phlaurent55]

Re : MACRO/Transposer pour retraitement base de données à plat

Re,

voir fichier joint ( explication sur la feuille)

à+
Philippe

 

[ador_matt]

Re : MACRO/Transposer pour retraitement base de données à plat

Bonjour Philippe et merci pour les explications complémentaires!

 

[klin89]

Re : MACRO/Transposer pour retraitement base de données à plat

Bonsoir à tous,

Une variante :

Sub Transpose()
Dim a, x As Long, i As Long, j As Byte, b()
    Application.ScreenUpdating = False
    With Range("A2").CurrentRegion
        a = .Value
    End With
    For i = 2 To UBound(a, 1)
        For j = 2 To UBound(a, 2)
            If Not IsEmpty(a(i, j)) Then
                x = x + 1
                ReDim Preserve b(1 To 3, 1 To x)
                b(1, x) = a(i, 1)
                b(2, x) = a(1, j)
                b(3, x) = a(i, j)
            End If
        Next
    Next
    With Range("A12")
        .CurrentRegion.Clear
        .Resize(, 3) = [{"Ma Référence Produit", "Concurrent", "Référence Concurrent"}]
        .Offset(1).Resize(UBound(b, 2), UBound(b, 1)) = _
        Application.Transpose(b)
        With .CurrentRegion
            .VerticalAlignment = xlCenter
            .BorderAround ColorIndex:=1, Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Interior.ColorIndex = 36
            .Columns(1).Interior.ColorIndex = 6
            With .Rows(1)
                .BorderAround ColorIndex:=1, Weight:=xlThin
                .Interior.ColorIndex = 44
                .HorizontalAlignment = xlCenter
                .WrapText = True
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[klin89]

Re : MACRO/Transposer pour retraitement base de données à plat

Re

On peut se passer de "ReDim Preserve"

Sub Transpose1()
Dim a, b(), x As Long, i As Long, j As Byte, k As Long
    Application.ScreenUpdating = False
    Range("A12").CurrentRegion.Clear
    With Range("A2").CurrentRegion
        x = WorksheetFunction.CountA(.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1))
        a = .Value
    End With
    If x = 0 Then Exit Sub
    ReDim b(1 To 3, 1 To x)
    For i = 2 To UBound(a, 1)
        For j = 2 To UBound(a, 2)
            If Not IsEmpty(a(i, j)) Then
                k = k + 1
                b(1, k) = a(i, 1)
                b(2, k) = a(1, j)
                b(3, k) = a(i, j)
            End If
        Next
    Next
    With Range("A12")
        .Resize(, 3) = [{"Ma Référence Produit", "Concurrent", "Référence Concurrent"}]
        .Offset(1).Resize(UBound(b, 2), UBound(b, 1)) = _
        Application.Transpose(b)
        With .CurrentRegion
            .VerticalAlignment = xlCenter
            .BorderAround ColorIndex:=1, Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Interior.ColorIndex = 36
            .Columns(1).Interior.ColorIndex = 6
            With .Rows(1)
                .BorderAround ColorIndex:=1, Weight:=xlThin
                .Interior.ColorIndex = 44
                .HorizontalAlignment = xlCenter
                .WrapText = True
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89