VBA- Réorganisation de données/affectation de caractère dans colonne

Bonjour, le Forum,

Je recherche une macro qui soit capable de reporter des données d'une colonne sur l'autre et de les réorganiser. Un truc en 4 étapes contenues dans mon fichier joint.

Merci de votre aide.

Bonjour James.

Voici un code répondant à ta demande :

Option Explicit

Sub consolidation()
Dim a(), a2(), n%, num As Byte, i%

'Enregistrement de la liste originale dans un tableau virtuel.
With Sheets(1)
    a = .Range("F1:F" & .[F65000].End(xlUp).Row).Value
End With

'Boucle pour connaître le nombre de valeurs à exporter.
For i = LBound(a) To UBound(a)
    If a(i, 1) = 5 Then n = n + 1
Next i

'Redimensionne le tableau final.
ReDim a2(1 To n, 1 To 2)
    n = 0
    For i = LBound(a) To UBound(a)
        If a(i, 1) = 5 Then
            n = n + 1
            If Not i = UBound(a) Then
                num = a(i, 1) & a(i + 1, 1)
                Else
                num = a(i, 1) & 0
            End If
            a2(n, 1) = num
            If num = 55 Then
                a2(n, 2) = 0
                Else
                a2(n, 2) = "*"
            End If
        End If
    Next i

'Exporte le tableau final
Sheets(1).[v1].Resize(UBound(a2), 2).Value = a2
End Sub

Salut et merci thebenoit59

J'ai oublié de préciser qu'il était important de conserver l'intégralité des lignes restantes eu égard aux données qu'elles contiennent et de respecter les colonnes afin de pouvoir exploiter les résultats pleinement. Voir mon 2me fichier joint.

Si tu peux apporter les modif nécessaires ce serait top...

Attention de toujours donner toutes les conditions lors d'une demande, ça évite ce genre de soucis.

Voici le code adapté, les valeurs correspondent.

Option Explicit

Sub consolidation()
Dim a(), a2(), n%, num As Byte, i%, j As Byte

'Enregistrement de la liste originale dans un tableau virtuel.
With Sheets(1)
    a = .Range("A1:G" & .[A65000].End(xlUp).Row).Value
End With

'Boucle pour connaître le nombre de valeurs à exporter.
For i = LBound(a) To UBound(a)
    If a(i, 6) = 5 Then n = n + 1
Next i

'Redimensionne le tableau final.
ReDim a2(1 To n, 1 To 9)
    n = 0
    For i = LBound(a) To UBound(a)
        If a(i, 6) = 5 Then
            n = n + 1
            For j = 1 To 7
                a2(n, j) = a(i, j)
            Next j
            If Not i = UBound(a) Then
                num = a(i, 6) & a(i + 1, 6)
                Else
                num = a(i, 6) & 0
            End If
            a2(n, 8) = num
            If num = 55 Then
                a2(n, 9) = 0
                Else
                a2(n, 9) = "*"
            End If
        End If
    Next i

'Exporte le tableau final
Sheets(1).[v1].Resize(UBound(a2), UBound(a2, 2)).Formula = a2
End Sub

Le résultat final s'inscrit à partir de la colonne V au lieu de la colonne A mais c'est pas bien grave, je ferais un copier/coller.

C'est déjà du Top comme cela.

Un grand merci à toi

Je ne sais pas où tu voulais la fin alors j'ai mis à partir de V1.

Si tu veux supprimer le tableau existant et remplacer :

'Exporte le tableau final
With Sheets(1)
.Cells.Clear
.[A1].Resize(UBound(a2), UBound(a2, 2)).Formula = a2
End With

Cool,

C'est vrai qu'avec le nombre de fichiers à gérer, si je peux économiser un copier/coller sur l'ensemble des fichiers à traiter ce ne sera que mieux.

En revanche, dans quelle partie de la macro je dois insérer le with/End with ?

Par ailleurs le tableau final étant plus petit que celui initial, est-ce qu'un reliquat de données de ce dernier ne va pas rester en fin de tableau final sur les colonnes A à I.

Je me trompe peut-être, mais en gardant ta macro avec le tableau inscrit en départ en colonne V, n'est-il pas pas mieux d'insérer en fin de macro la commande : "supprimer les colonnes A à U" ?

Qu'en penses-tu ?

Tu dois modifier le code après :

'Exporte le tableau final

Un simple copier/coller.

Le code modifié supprime les cellules existantes et insère le tableau final.

Just Perfect...