Modification VBA (details)

Bonjour a tous

je reviens vers vous pour que vous m'aidiez pour un détails,

je vous explique

je dois créer une Macro qui va générer des écritures comptables pour pouvoir les intégrer plus facilement dans un logiciels de compta, ce que j'ai réussi a créer avec l'aide d'un collègues du FORUM que je remercie énormément, le HIC c'est que j'ai adapter la macro qu'il a crée et je n'arrive pas a afficher la totalité de ma colonne Compte( ca les affiche sur les 3 premières lignes mais pas la suite ) avec les différentes valeurs ca prend en compte ma fonctions mais ca n'affiche que le même numéro de compte. Voir ex

pour mieux comprendre j'ai mis un fichier exemple avec ma feuille BASE qui est ma feuille ou je dois filtrer mes données, une feuille "ResultatMacro" qui est le résultat quand j'active ma macro et j'ai la feuille RésultatVoulu qui dois être mon résultat final pour pouvoir l'intégrer dans mon logiciel de comptabilité.

et voici mon code VBA

si quelqu'un pourrait m'aider a trouver mon erreur ? S'il vous plait

je pense que mon erreur se situe ou il y a :

 For I = 2 To UBound(tbl)
        ReDim Preserve arr(6, k + 1 + 1)
        arr(0, k) = tbl(I, 1)
        arr(1, k) = "CA"
        arr(2, k) = "5300000"
        arr(2, 1) = "7070000"
        arr(2, 2) = "4457100"

Option Explicit

Public Sub TransformData()
Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet
Dim tbl As Variant, arr() As Variant
Dim I As Long, k As Long
Dim n As Double

    Set wb = ActiveWorkbook
    n = wb.Worksheets.Count
    Set ws = wb.Worksheets("Base")
    tbl = ws.Cells(1).CurrentRegion.Value2

    Set ws2 = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    ws2.Name = "FiltreReglement" & n

    For I = 2 To UBound(tbl)
        ReDim Preserve arr(6, k + 1 + 1)
        arr(0, k) = tbl(I, 1)
        arr(1, k) = "CA"
        arr(2, k) = "5300000"
        arr(2, 1) = "7070000"
        arr(2, 2) = "4457100"

            If tbl(I, 5) = "D" Then
                arr(3, k) = tbl(I, 6)
            Else
                arr(4, k) = tbl(I, 6)
            End If
        arr(5, k) = tbl(I, 7)
        k = k + 1

    Next I

    With ws2
        .Cells(2, 1).Resize(, 6).Value = Array("date rgt", "code journal", "compte", "débit", "crédit", "Libellé")
        .Cells(3, 1).Resize(k, 6).Value = Application.Transpose(arr)
    End With

End Sub

Bonjour,

Si j'ai bien compris, remplacez ces 3 lignes

 arr(2, k) = "5300000"
        arr(2, 1) = "7070000"
        arr(2, 2) = "4457100"

par celle-ci, uniquement

        arr(2, k) = Left(tbl(I, 3) * 1000, 7)

Cdlt

bonjour Arturo83, DragZ, le fil,

on peut utiliser TBL le reste de la macro, sans transposer et les 6 premières colonnes

Public Sub TransformData()
     Dim Tbl, i As Long

     Tbl = Sheets("Base").Range("A1").CurrentRegion.Offset(1).Resize(, 7).Value2   'vos données à partir de la 2eme ligne >>> tblay

     For i = 1 To UBound(Tbl) - 1   'boucle les données
          Tbl(i, 3) = "'" & Left(Tbl(i, 3) & "000000", 6)     'code journalier
          Tbl(i, 6) = CDbl(Trim(Replace(Tbl(i, 6), ".", ",")))     'convertir
          Select Case UCase(Tbl(i, 5))     'majuscule
               Case "D": Tbl(i, 4) = Tbl(i, 6): Tbl(i, 5) = ""
               Case "C": Tbl(i, 4) = "": Tbl(i, 5) = Tbl(i, 6)
               Case Else: Tbl(i, 4) = "???" & Tbl(i, 6): Tbl(i, 5) = Tbl(i, 4)
          End Select
          Tbl(i, 6) = Tbl(i, 7)
     Next

     With Worksheets.Add(after:=Worksheets(Worksheets.Count))     'ajouter feuille
          .Name = "FiltreReglement" & ThisWorkbook.Worksheets.Count     'nom de la feuille
          .Columns(1).NumberFormat = "dd/mm/yy"     '1er colonne est date
          .Range("D:E").NumberFormat = "#,##0.00 €"     '4 et 5 sont currency
          .Cells(2, 1).Resize(, 6).Value = Array("date rgt", "code journal", "compte", "débit", "crédit", "Libellé")     '1er ligne
          .Cells(3, 1).Resize(UBound(Tbl), 6).Value = Tbl     'seulement les 6 premieres colonnes
     End With

End Sub

Merci bien a vous tous

vos deux solution fonctionne très bien :) et vous m'avez fais comprendre mon erreur je vous en remercie mille fois