[VBA] Collage transposé spécial avec dédoublonnement de données

[ralph45]

Bonjour le forum !!

De retour après quelques mois d'absence participative et me voilà avec une demande d'aide en VBA.

Dans un fichier, j'aurai besoin de faire un type de copier/coller transposé particulier : pour chaque personne référencée (CD_USER), il faudrait mettre en ligne les informations relatives à ses formations effectuées ou à venir (ORG1, ORG2, ORG3).

Comme mes explications ne sont pas faciles, vous trouverez dans le fichier allégé et anonymisé joint le tableau de départ (onglet AVANT) et le résultat attendu (onglet APRES).

Contraintes :
- EXCEL 2010 ;
- Le "vrai" fichier comporte plus de 25 000 lignes ;
- cela va de 1 à "n" personnes (CD_USER) ;
- La triplette de départ (ORG1, ORG2 & ORG3) peut être de l'ordre maxi de 200 lignes pour chaque CD_USER ;
- Le code devra fonctionner sur un seul onglet (une sorte de remplacement).

Je pense avoir tout écrit... 😛 et merci de l'attention que vous saurez y donner !

A+

 

[Compte Supprimé 979]

Re : [VBA] Collage transposé spécial avec dédoublonnement de données

Salut Ralph45 ;-)

Essaye ce code pour voir si ça peut te convenir

Sub Transposition()
  Dim Sht As Worksheet
  Dim DLig As Long, Lig As Long, NbLig As Integer, FirstL As Long
  Dim Col As Integer, MaxCol As Integer, NumOrg As Integer
  Dim sUser As String
  ' Désactiver certaines fonctions
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  ' Initialiser les variables
  Set Sht = Sheets("AVANT")
  DLig = Sht.Range("A" & Rows.Count).End(xlUp).Row
  FirstL = 2: Lig = 3
  ' Pour chaque ligne
  Do While Sht.Range("A" & Lig) <> ""
    ' Récupérer la référence utilisateur
    sUser = Sht.Range("A" & FirstL).Value
    ' Récupérer le numéro de la première ligne de l'utilisateur
    NbLig = Application.WorksheetFunction.CountIf(Sht.Range("A:A"), sUser)
    ' Inscrire les éléments sur la première ligne
    Do While Sht.Range("A" & Lig) = sUser
      ' Prochaine colonne vide
      Col = Sht.Cells(FirstL, Columns.Count).End(xlToLeft).Column
      NumOrg = Right(Sht.Cells(1, Col), 1)
      Col = Col + (3 - NumOrg) + 1
      ' Vérifier le numéro de la dernière
      MaxCol = Sht.Cells(1, Columns.Count).End(xlToLeft).Column
      ' Si la prochaine colonne vide est > à la dernière
      If Col > MaxCol Then
        ' copier / coller les entêtes puis le format des colonnes
        Sht.Range("D1:F1").Copy Destination:=Sht.Cells(1, Col)
        Sht.Range("D:F").Copy
        Sht.Cells(1, Col).PasteSpecial Paste:=xlPasteFormats
      End If
      ' Copier coller les informations
      Sht.Range("D" & Lig & ":F" & Lig).Copy Destination:=Sht.Cells(FirstL, Col)
      ' Supprimer la ligne
      Sht.Rows(Lig).Delete
    Loop
    ' Définir la nouvelle première ligne
    FirstL = Lig: Lig = FirstL + 1
  Loop
  ' Ré-activer les fonctions
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

A+

 

[ralph45]

Re : [VBA] Collage transposé spécial avec dédoublonnement de données

Bonjour le Forum, BrunoM45,

Après une grosse coupure de courant et une multitude de tests, je reviens pour te dire un grand merci : ton code fonctionne à merveille !! 😛
Et chapeau bas encore pour tes explications !

A bientôt... Ralph45