Tableau qui s'adapte en fonction d'un autre

Bonjour à tous,

J'ai un petit problème concernant une marco que je souhaite modifier, j'avais crée une marco pour avoir copier toutes les données d'un tableau (A) dans un autre tableau (B). je pouvais donc coller le tableau A plein de données pour les avoir d'une maniéré assez jolie dans le tableau (B).

Cependant, je souhaite maintenant avoir un tableau (B) qui ne colle que certaines données du tableau (A).

Je souhaite donc avoir un tableau (B) qui se crée en fonction d'un autre tableau (A). J'ai mis un exemple de ce que j'aimerais atteindre en copie.

Si vous avez des pistes pour créer un tableau qui se s'adapte en fonction des cases d'un autre tableaux je suis preneur.

Merci,

Cordialement.

Cabouse

Salut Cabouse,

quelque chose comme ça qui mériterait meilleure finition, d'ailleurs...

Un double-clic pour démarrer la macro...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData
Cancel = True
'
Range("J1:Z35").ClearContents
iRow = Range("A" & Rows.Count).End(xlUp).Row
iCol = Range("A1").End(xlToRight).Column - 1
sCol = Split(Columns(iCol).Address(ColumnAbsolute:=False), ":")(1)
sCol1 = Split(Columns(iCol + 3).Address(ColumnAbsolute:=False), ":")(1)
'
Range(sCol1 & 1).Resize(iCol, iRow) = WorksheetFunction.Transpose(Range("A1:" & sCol & iRow))
For x = Cells(1, Columns.Count).End(xlToLeft).Column To iCol + 3 Step -1
    If Left(Cells(1, x), 5) = "Total" Then Columns(x).Delete shift:=xlToLeft
Next
'
iCol1 = Cells(1, Columns.Count).End(xlToLeft).Column + 1
sCol = Split(Columns(iCol1).Address(ColumnAbsolute:=False), ":")(1)
sCol2 = Split(Columns(iCol1 - 1).Address(ColumnAbsolute:=False), ":")(1)
For x = 1 To iCol
    Range(sCol & x).FormulaLocal = IIf(x = 1, "Total", "=SOMME(" & sCol1 & x & ":" & sCol2 & x & ")")
Next
'
End Sub

A+

Salut curulis57,

Merci beaucoup pour ta réponse. Je vais abuser un peu plus de ta gentillesse si tu as le temps. Est ce que c'est possible pour le dernier exemple que le tableau n'affiche pas la colonne j,t et u ?

Merci,

Salut Cabouse,

j'ai ajouté la ligne "U" pour tester plusieurs configurations de tableaux.

Par contre, les deux autres y étaient déjà!

Veux-tu dire par là que tu veux pouvoir choisir les éléments à conserver pour la transformation?

A+

Salut,

oui, c'est ce que j’aimerai faire si tu peux ou si tu as une idée ?

J'aimerai que quelque soit la longeure de mon tableau, la marco sélectionne toujours les lettre a,b,c,d,e,f si elles y sont et pas d'autres lettres.

Merci.

Tu voulais supprimer j, t, u...

Quid de "G" ?

J'aimerais également intégrer G pardon

Rien de compliqué mais j'aimerais savoir quelle présentation ces lettres ont dans la réalité de ton travail :

• est-ce vraiment a, b, c,... ?
• A, B, C... ?
• André, Paul, Jacques...
• QYG/nh89, DFR-O-M90,... ?

La méthode de recherche des colonnes à supprimer n'est pas toujours la même!!

A+

Ce n'est pas à b, c, d c'est plus : +carte, +chèque, -débit ect...

Si t'y arrive ça serais super.

Merci.

Donne-moi exactement les intitulés des colonnes à garder!

Tu n'aurais pas été très loin avec tes a, b, c, d...

+CAR, +CHQ, +CSH, +INT, +NTI, -DDC, -NTI, -INT,-SEP

je pensais que comme c'était des chaînes de caractères c'était la même choses et je pouvais changer a , b, c...par +INT

Les nouveaux tableaux doivent-ils remplacer les anciens ou bien rester à côté comme j'ai fait?

Rester à coter ou sur une nouvelle page.

Merci.

Bonjourr Cabouse, curulis57

Pour le fun une version "bombe atomique"

Sub TransposerTablo()
Dim tabBase()
Dim cptBase, colBase
Dim copElem

Dim tabSwap()
Dim nbrSwap
Dim colSwap

    Range(Cells(1, 11), Cells(1, 20)).EntireColumn.ClearContents
    nbrSwap = 0
    copElem = "+CAR +CHQ +CSH +INT +NTI -DDC -NTI -INT -SEP"
    tabBase = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 9))
    For cptBase = 1 To UBound(tabBase, 1)
        If (cptBase = 1) Or (InStr(copElem, Left(tabBase(cptBase, 1), 4)) > 0) Then
            nbrSwap = nbrSwap + 1
            ReDim Preserve tabSwap(1 To UBound(tabBase, 2), 1 To nbrSwap)
            totSwap = 0
            For colBase = 1 To UBound(tabBase, 2) - 1
                tabSwap(colBase, nbrSwap) = tabBase(cptBase, colBase)
            Next
        End If
    Next

    ReDim Preserve tabSwap(1 To UBound(tabSwap, 1), 1 To UBound(tabSwap, 2) + 1)
    For nbrSwap = 2 To UBound(tabSwap, 1) - 1
        For colSwap = 2 To UBound(tabSwap, 2) - 1
            tabSwap(nbrSwap, UBound(tabSwap, 2)) = tabSwap(nbrSwap, UBound(tabSwap, 2)) + tabSwap(nbrSwap, colSwap)
        Next
    Next

    Cells(1, 11).Resize(UBound(tabSwap, 1), UBound(tabSwap, 2)) = tabSwap

End Sub

Voilà Cabouse,

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Application.ScreenUpdating = False
'
Cancel = True
'
Range("J1:Z50").ClearContents
Range("J1:Z50").Borders.LineStyle = xlLineStyleNone
Range("J1:Z50").Interior.Color = xlNone
'
iRow = Range("A" & Rows.Count).End(xlUp).Row
iCol = Range("A1").End(xlToRight).Column - 1
sCol = Split(Columns(iCol).Address(ColumnAbsolute:=False), ":")(1)
sCol1 = Split(Columns(iCol + 3).Address(ColumnAbsolute:=False), ":")(1)
'
Range(sCol1 & 1).Resize(iCol, iRow) = WorksheetFunction.Transpose(Range("A1:" & sCol & iRow))
For x = Cells(1, Columns.Count).End(xlToLeft).Column To iCol + 3 Step -1
    iFlag = 0
    For y = 1 To 9
        If Cells(1, x) = Choose(y, "+CAR", "+CHQ", "+CSH", "+INT", "+NTI", "-DDC", "-NTI", "-INT", "-SEP") Then iFlag = 1
    Next
    If iFlag = 0 Then Columns(x).Delete shift:=xlToLeft
Next
'
iCol1 = Cells(1, Columns.Count).End(xlToLeft).Column + 1
sCol = Split(Columns(iCol1).Address(ColumnAbsolute:=False), ":")(1)
sCol2 = Split(Columns(iCol1 - 1).Address(ColumnAbsolute:=False), ":")(1)
For x = 1 To iCol
    Range(sCol & x).FormulaLocal = IIf(x = 1, "Total", "=SOMME(" & sCol1 & x & ":" & sCol2 & x & ")")
Next
Range(sCol1 & "1:" & sCol & iCol).Borders.LineStyle = xlContinuous
Range(sCol1 & "1:" & sCol & iCol).BorderAround Weight:=xlMedium
Range(sCol1 & "1:" & sCol & 1).BorderAround Weight:=xlMedium
Range(sCol1 & "1:" & sCol & 1).Interior.Color = RGB(215, 215, 215)
Range(sCol & "2:" & sCol & iCol).Interior.Color = RGB(240, 240, 240)
'
Application.ScreenUpdating = True
'
End Sub

A tester dans un environnement de travail réel afin d'ajuster les normes d'affichage du nouveau tableau.

pour l'instant, il s'afficheront toujours en [K1] ce qui peut-être forcément insuffisant dans la réalité.

A+

Bonjour curulis57, NCC 1701,

Merci beaucoup à tous les deux

Vous m'avez sauvez