Macro de transposition

Bonjour,

Je me présente de nouveau à vous, âpres vos nombreux sucée dans mes demandes précédentes, je vous remercie encore pour cela !

Je vais profiter de mes vacances d'été pour apprendre un peut le VBA. Mais avant cela j'ai encore besoin de votre aide ;(

J'ai un fichier Excel présenté en ligne,

<TRNTYPE OTHER

<DTPOSTED 20160130

<TRNAMT -1519.64

<FITID 4209200718416

<NAME VIREMENT EMIS

<MEMO WEB XXXXXXXXXXXXXXXXXX

J'aimerais que ce fichier ce transforme en colonne :

<TRNTYPE <DTPOSTED <TRNAMT <FITID <NAME <MEMO

OTHER 20160104 -942.23 4209230022818 VIREMENT EMIS WEB XXXXXXXXXXXXX

C'est très simple à faire avec un copié/coller transposer, mais sur plus de 150 000 ligne, cela me parait long, très très long...

je suis sur que vous avez une solution magique grâce au VBA presque aussi magique que vos esprit affuté

Le problème est que je ne veut que la 2nd colonne la 1er étant les titre qui ce répète,

Le second problème est que le fichier est dans un format particulier. En effet, les cellule a transposer ne ce suivent pas, elle sont séparer par d'autre ligne.

Le dernier problème est que j'ai plusieurs fichier a traiter, chacun ce présentant de la même manière.

Je vous joint un morceau d'un des fichiers anonymé, avec un onglet correspondant au fichier d'origine et le second avec le résultat que je souhaite.

Dans le cas ou vous n'arriver pas a m'aider, je me voie obliger d'engager mon fils pour faire des copier coller toute la journée

Merci bien à vous d'avance.

Bonjour Kyopi.

J'ai peur qu'avec un fichier aussi lourd que celui dont tu parles, la transposition prenne un temps phénoménal.

Pour réduire ce temps, je suis parti sur un enregistrement en tableau virtuel, de toutes les valeurs de la feuille "Origine".

Ensuite j'ai créé un Index en fonction des valeurs en colonne [A].

Sur la feuille "Voulu", on boucle les valeurs en ligne [1] pour rechercher son existence dans l'index.

On sort toutes les lignes correspondantes au critère.

Option Explicit

Sub Transposition()
Dim l&, t(), temp(), d As Object, n$

'Enregistrement du tableau
With Sheets("Origine")
    l = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    t = .Range(.Cells(1, 1), .Cells(l, 2)).Value
End With

'Enregistrement de l'index
Set d = CreateObject("scripting.dictionary")
For l = LBound(t) To UBound(t)
    d(t(l, 1)) = d(t(l, 1)) & l & ":"
Next l

'On exporte les valeurs colonnes par colonnes
With Sheets("Voulu")
    l = 1
    Do While .Cells(1, l).Value <> ""
        'On vérifie si la valeur existe dans l'index
        n = "<" & .Cells(1, l).Value
        If d.exists(n) Then
            temp = Application.Index(t, Application.Transpose(Split(d(n), ":")), 2)
            With .Cells(2, l).Resize(UBound(temp) - 1)
                .NumberFormat = "@"
                .Value = temp
            End With
        End If
        l = l + 1
    Loop
End With
End Sub

Bonjour,

Déjà un grand merci de m'aider !

Ton idée est vraiment "smart". Je vais essayer, cela et je revient "edit" mon message avec le résultat, mais cela me parait efficace est très bien !

Pour le temps, j'ai pas de soucis a ce niveau la, ce sera toujours plus rapide que si c'est mon fils qui le fait

Merci !

EDIT :

je viens donc d'essayer, j'ai réussi à la faire fonctionner c'est déjà bien ^^

Donc cela est très rapide, mais je n'est aucun moyen de vérifier que aucune ligne a été "oublier" par la macro. Je verrais donc cela au final !

Mais c'est déjà très bien !

Je termine mon dossier, je vérifie les donnée et je vous offre un café si tous cela fonctionne :!

Qu'entends-tu par aucune ligne oubliée ?

Tu peux vérifier basiquement sous excel avec un NB.SI pour connaître le nombre de valeur de la feuille "Origine" par en-tête et vérifier dans la feuille "Voulu" le nombre de lignes inscrites.

bonjour,

Autre solution:

Sub test()
Dim i, ii, k, a
Application.ScreenUpdating = False
Sheets("Feuil3").Columns(4).NumberFormat = "@"
With Sheets("Origine")
   ii = .[A1].CurrentRegion.Rows.Count
   For i = 1 To ii Step 8
   a = .Range(.Cells(i, 2), .Cells(i + 5, 2)).Value
   Sheets("Feuil3").Cells(k + 1, 1).Resize(1, UBound(a)) = Application.Transpose(a)
   k = k + 1
   Next
End With
End Sub

A+

Oui, je n'y avais pas pensé !

Donc oui toutes les lignes sont la !!

Un grand merci a toi mon problème est résolue !! Avec une rapidité et une efficacité incroyable !

J'attends le café maintenant

Edit: Bonjour Galopin.

Re,

Autre solution (Plus rapide) :

Sub test2()
Dim i%, ii, k, kk%, a, b(1 To 20000, 1 To 6)
Application.ScreenUpdating = False
Sheets("Feuil3").Columns(4).NumberFormat = "@"
k = 1
With Sheets("Origine")
   ii = .[A1].CurrentRegion.Rows.Count
   For i = 1 To ii Step 8
      a = .Range(.Cells(i, 2), .Cells(i + 5, 2)).Value
      For kk = 1 To 6
         b(k, kk) = a(kk, 1)
      Next
      k = k + 1
   Next
Sheets("Feuil3").[A1].Resize(UBound(a), 6) = b
End With
End Sub

Encore une solution (la plus rapide) :

Sub test3()
Dim i%, ii, k, kk%, a, b(1 To 20000, 1 To 6)
Application.ScreenUpdating = False
Sheets("Feuil3").Columns(4).NumberFormat = "@"
k = 1
With Sheets("Origine")
   ii = .[A1].CurrentRegion.Rows.Count
   a = .[A1].CurrentRegion
   For i = 1 To ii Step 8
      For kk = 1 To 6
         b(k, kk) = a(kk + i - 1, 2)
      Next
      k = k + 1
   Next
Sheets("Feuil3").[A1].Resize(UBound(a), 6) = b
End With
End Sub

A+

Pour le Café, ya pas de problème, mais je suis sur Angers (49), je vous attend