[Macro] Transposition de tableau

Le 20/11/2015 à 12:34

Bonjour à tous,

Je sollicite à nouveau votre aide dans la réalisation de formules ou de macros (voir fichier joint), je souhaite en effet parvenir aux rendus suivants :

  • Automatiser le tableau dans la feuille "Rendu" à partir des données de l'onglet "Recettes"
  • Supprimer les lignes vides selon une condition.
  • Éventuellement l'ajout de X lignes entre chaque lignes d'une plage.

Je vous détaille un peu plus le rendu que je souhaite obtenir :

D'après les lignes qui correspondent à des recettes journalières, je souhaite préparer des écritures comptable sous le modèle de ma feuille "Rendu". Sachant que pour faire simple, chaque journée comprend les mêmes données (recettes en C.B., chèques ou espèces) qui correspondent aux mêmes types de comptes (donc la schéma de la journée 1 va se reproduire sur toutes les autres).

Après cette macro, je souhaite supprimer l'ensemble des lignes avec la condition : Colonne G et H vides (dans l'exemple, la ligne 3 sera supprimée), de manière à ce que si un élément n'apparait pas, il n'y est pas de lignes.

Un grand merci d'avance et à bientôt.

12test-mac.zip (6.95 Ko)
Le 20/11/2015 à 23:15

Bonsoir,

Ci-joint une proposition, à tester.

Un point à préciser :

Éventuellement l'ajout de X lignes entre chaque lignes d'une plage.

Bonne soirée !

Bouben

18test-mac-v0-1.zip (15.77 Ko)
Le 20/11/2015 à 23:27

Bonsoir à tous,

A tester :

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte
    Application.ScreenUpdating = False
    With Sheets("Recettes").Range("A1").CurrentRegion.Resize(, 6)
        a = .Value
    End With
    ReDim b(1 To UBound(a, 1) * 5, 1 To 8)
    b(1, 1) = "Code journal": b(1, 2) = "Date de pièce"
    b(1, 3) = "N° de compte": b(1, 4) = "Libellé compte"
    b(1, 5) = "N°pièce": b(1, 6) = "Libellé mvts"
    b(1, 7) = "Débit": b(1, 8) = "Crédit"
    n = 1
    For i = 2 To UBound(a, 1)
        For j = 2 To UBound(a, 2)
            n = n + 1
            b(n, 1) = "VE": b(n, 2) = a(i, 1): b(n, 3) = "411" & a(1, j)
            If j = 5 Then b(n, 3) = "707131"
            If j = 6 Then b(n, 3) = "44571"
            b(n, 6) = "Journée du " & a(i, 1)
            If j <> 5 Then b(n, 7) = a(i, j)
            If j = 5 Then b(n, 8) = a(i, j) / 1.2
            If j = 6 Then b(n, 8) = b(n - 1, 8) * 0.2
        Next
    Next
    'Restitution
    With Sheets("Rendu")
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).FormulaLocal = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns("g:h").HorizontalAlignment = Array(1, 1)
                .Columns("g:h").NumberFormat = Array("#,##0.00", "#,##0.00")
                .Columns.AutoFit
                .Columns("g:h").ColumnWidth = Array(12, 12)
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 23/11/2015 à 11:33

Bonjour,

Tout d'abord, un grand merci à tous les deux pour vos macros !

Je viens de la tester, ça fonctionne très bien .

Celle de bouben a la petite fonction qui supprime les lignes, c'est parfait.

J'ai appris tout ce dont j'avais besoin en analysant le code ^^.

Pour cette partie :

Éventuellement l'ajout de X lignes entre chaque lignes d'une plage.

Laissez tomber, je voulais juste voir si on pouvait faire une insertion de 3/4 lignes entre chaque lignes sur un tableau.

Le 25/11/2015 à 16:10

Re Alevi,

Le code réajusté :

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte, k As Long
    Application.ScreenUpdating = False
    With Sheets("Recettes").Range("A1").CurrentRegion
        a = .Value
    End With
    ReDim b(1 To UBound(a, 1) * 5, 1 To 8)
    b(1, 1) = "Code journal": b(1, 2) = "Date de pièce"
    b(1, 3) = "N° de compte": b(1, 4) = "Libellé compte"
    b(1, 5) = "N°pièce": b(1, 6) = "Libellé mvts"
    b(1, 7) = "Débit": b(1, 8) = "Crédit"
    n = 1
    For i = 2 To UBound(a, 1)
        k = n
        For j = 2 To UBound(a, 2) - 1
            If Not IsEmpty(a(i, j)) Then
                n = n + 1
                b(n, 1) = "VE": b(n, 2) = a(i, 1): b(n, 3) = "411" & a(1, j)
                b(n, 6) = "Journée du " & a(i, 1)
                b(n, 7) = a(i, j)
            End If
        Next
        If n > k Then
            n = n + 2
            b(n - 1, 1) = "VE": b(n - 1, 2) = a(i, 1): b(n - 1, 3) = "707131"
            b(n - 1, 6) = "Journée du " & a(i, 1): b(n - 1, 8) = a(i, 5) / 1.2
            b(n, 1) = "VE": b(n, 2) = a(i, 1): b(n, 3) = "44571"
            b(n, 6) = "Journée du " & a(i, 1): b(n, 8) = b(n - 1, 8) * 0.2
        End If
    Next
    'Restitution
    'With Sheets("Rendu")
    With Sheets("Feuil1")
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).FormulaLocal = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns("g:h").HorizontalAlignment = Array(1, 1)
                .Columns("g:h").NumberFormat = Array("#,##0.00", "#,##0.00")
                .Columns.AutoFit
                .Columns("g:h").ColumnWidth = Array(12, 12)
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 25/11/2015 à 16:32
Klin89 a écrit :

Re Alevi,

Le code réajusté :

klin89

Merci .

Je reviens vers vous car j'ai essayer des modifications en vain.

J'aimerai maintenant obtenir un rendu très similaire :

L'onglet Rendu ne prendrait en compte que les entrées (donc pas de lignes vides) sous le modèle actuel :

code journal date de piece n° compte libelle compte n° piece libelle mvts debit credit

CA X 5311 RECETTE ESPECES X

CA X 411ESPECES RECETTE ESPECES X

Je réactive donc temporairement le sujet, merci d'avance

16test-caisse.zip (12.76 Ko)
Le 26/11/2015 à 19:04

Bonsoir à tous,

Pas très claire, ta dernière demande 

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte, k As Long
    Application.ScreenUpdating = False
    With Sheets("Recettes").Range("A1").CurrentRegion
        a = .Value
    End With
    ReDim b(1 To UBound(a, 1) * 2, 1 To 8)
    b(1, 1) = "Code journal": b(1, 2) = "Date de pièce"
    b(1, 3) = "N° de compte": b(1, 4) = "Libellé compte"
    b(1, 5) = "N°pièce": b(1, 6) = "Libellé mvts"
    b(1, 7) = "Débit": b(1, 8) = "Crédit"
    n = 1
    For i = 2 To UBound(a, 1)
        If Not IsEmpty(a(i, 2)) Then
            n = n + 2
            b(n - 1, 1) = "CA": b(n - 1, 2) = a(i, 1): b(n - 1, 3) = "5311"
            b(n - 1, 6) = "Recette espèces": b(n - 1, 7) = a(i, 2)
            b(n, 1) = "CA": b(n, 2) = a(i, 1): b(n, 3) = "411ESPECES"
            b(n, 6) = "Recette espèces": b(n, 8) = a(i, 2)
        End If
    Next
    'Restitution
    'With Sheets("Rendu")
    With Sheets("Feuil1")
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).FormulaLocal = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns("g:h").HorizontalAlignment = Array(1, 1)
                .Columns("g:h").NumberFormat = Array("#,##0.00", "#,##0.00")
                .Columns.AutoFit
                .Columns("g:h").ColumnWidth = Array(12, 12)
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 26/11/2015 à 20:46
Klin89 a écrit :

Bonsoir à tous,

Pas très claire, ta dernière demande

Salut,

Bah désolé, je pensais que l'exemple que j'avais fait suffirait ^^'. J'étais un peu pressé .

Mais sinon, c'est vraiment parfait, c'est tout à fait ce que je recherchais (j'ai juste du modifier la ligne With Sheets("Feuil1") avec "Rendu").

Je vais prendre le temps de décortiquer un peu mieux le code pour ne pas vous déranger à chaque fois que j'essaye de l'adapter xD.

Encore merci pour le temps passé là dessus en espérant que ça puisse également en aider d'autres.

Rechercher des sujets similaires à "macro transposition tableau"