Fonction ? meme nom sur une seule ligne

[laurent70190]

Bonjour a tous,

je viens a vous en total debutant.

J'ai un fichier fichier excel fait sous ce principe (voir fic1)

mais le fichier est grand et je souhaiterais arriver a ce resultat (fic2)

Est ce possible ?

merci d'avance pour votre aide

Cordialement

 

[gosselien]

Bonjour,
je ne sais pas faire mais si tu expliquais le but de la manœuvre pour les petits camarades de classe qui eux savent faire ?
et ?...tu fais souvent des onglets sans titre de colonne ?

P.

 

[Paf]

Bonjour laurent70190, gosselien,

le fichier fic2 montre que les données doivent respecter leur colonne d'origine.
est ce impératif ?

si oui, est ce qu' il n'y aura pas plus de données pour un individu que le nombre de colonnes initiales( ici 4) ?

de la réponse dépend la façon d'envisager le code.

A+

 

[job75]

Bonsoir laurent70190, gosselien, Paf,

La macro dans le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, t, d As Object, i&, j%, a, b, resu(), s, x
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
Set P = Feuil1.[A1].CurrentRegion 'CodeName Feuil1
ncol = Application.Ceiling(P.Columns.Count, 2) 'sécurité (nombre pair)
t = P.Resize(, ncol)
Set d = CreateObject("Scripting.Dictionary")
'---liste des noms sans doublon et valeurs concaténées---
For i = 1 To UBound(t)
  For j = 1 To ncol Step 2
    If t(i, j) <> "" Then d(t(i, j)) = d(t(i, j)) & "#" & 1 + (j + 1) / 2 & " " & t(i, j + 1)
Next j, i
If d.Count = 0 Then Exit Sub
'---tableau des résultats---
a = d.keys: b = d.items
ReDim resu(1 To d.Count, 1 To 1 + ncol / 2)
For i = 0 To UBound(a)
  resu(i + 1, 1) = a(i)
  s = Split(Mid(b(i), 2), "#")
  For j = 0 To UBound(s)
    x = Split(s(j))
    resu(i + 1, x(0)) = x(1)
Next j, i
'---restitution---
[A1].Resize(d.Count, UBound(resu, 2)) = resu
End Sub

Elle se déclenche quand on active la feuille.

Fichier joint.

Bonne soirée.

 

[job75]

Re,

J'ai enregistré le fichier en .xlsm et copié le tableau A1:H3 sur 16000 colonnes :

Sub Copier()
With [A1:H3]
  .Copy .Resize(, 16000)
End With
End Sub

Sur Win 10 - Excel 2013 la macro Worksheet_Activate s'exécute en 1,03 seconde.

Fichier joint.

Bonne fin de soirée et bonne nuit.

 

[gosselien]

Bonjour Job75 et le demandeur absent ... 🙂

beau code 🙂 0.42 sec chez moi win10/excel 2016 Dell 24 Gg ram et idem avec Excel 2010 🙂

P.

 

[job75]

Bonjour le fil, le forum,

gosselien se posait la question des titres de colonnes.

Il y en a dans ce fichier (2).

Bonne journée.

Edit : salut gosselien, une RAM de 24 Go dites donc !

Mon ASUS n'a que 4 Go et mon processeur traîne un peu avec 1,70 GHz.

 

[gosselien]

Edit : salut gosselien, une RAM de 24 Go dites donc !

Mon ASUS n'a que 4 Go et mon processeur traîne un peu avec 1,70 GHz.

Il est neuf (de janvier) 🙂 j'ai eu fatalement une machine avec le(s) processeur(s) le(s) 4.00 Ghz plus récent(s) et autant y aller pour la ram pour être à l'abri 🙂

 

[job75]

Re,

Il faut éventuellement utiliser des séparateurs meilleurs pour les concaténations :

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, t, d As Object, sep1$, sep2$, i&, j%, a, b, resu(), s, x
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
Set P = Feuil1.[A1].CurrentRegion 'CodeName Feuil1
ncol = Application.Ceiling(P.Columns.Count, 2) 'sécurité (nombre pair)
t = P.Resize(, ncol)
Set d = CreateObject("Scripting.Dictionary")
sep1 = Chr(1): sep2 = Chr(2)
'---liste des noms sans doublon et valeurs concaténées---
For i = 2 To UBound(t)
  For j = 1 To ncol Step 2
    If t(i, j) <> "" Then d(t(i, j)) = d(t(i, j)) & sep1 & 1 + (j + 1) / 2 & sep2 & t(i, j + 1)
Next j, i
If d.Count = 0 Then GoTo 1
'---tableau des résultats---
a = d.keys: b = d.items
ReDim resu(1 To d.Count + 1, 1 To 1 + ncol / 2)
For i = 0 To UBound(a)
  resu(i + 2, 1) = a(i)
  s = Split(b(i), sep1)
  For j = 1 To UBound(s)
    x = Split(s(j), sep2)
    resu(i + 2, x(0)) = x(1)
Next j, i
'---titres---
resu(1, 1) = "Nom"
For j = 2 To UBound(resu, 2)
  resu(1, j) = t(1, 2 * j - 3)
Next
'---restitution---
[A1].Resize(UBound(resu), UBound(resu, 2)) = resu
1 Columns.AutoFit 'ajustement largeur
With Me.UsedRange: End With 'actualisation des barres de défilement
End Sub

Fichiers joints, pour le 2ème fichier durée d'exécution 3,5 secondes (plusieurs essais).

A+

 

[Paf]

re et bonjour job75,

un essai macro:

Sub TransP()
Dim dico, i As Long, j As Long, T1, T2, T3, Clé, Maxi As Long
Set dico = CreateObject("Scripting.Dictionary")
T1 = Worksheets("Feuille1").Range("A1").CurrentRegion
For j = LBound(T1, 2) To UBound(T1, 2) Step 2
    For i = LBound(T1, 1) To UBound(T1, 1)
        dico(T1(i, j)) = dico(T1(i, j)) + 1
    Next
Next
Maxi = 0
For Each Clé In dico.keys
    If dico(Clé) > Maxi Then Maxi = dico(Clé)
    dico(Clé) = Null
Next
ReDim T2(0 To Maxi - 1)
T3 = T2
For j = LBound(T1, 2) To UBound(T1, 2) Step 2
    For i = LBound(T1, 1) To UBound(T1, 1)
        If IsNull(dico(T1(i, j))) Then dico(T1(i, j)) = T3
        T2 = dico(T1(i, j))
        T2(((j + 1) / 2) - 1) = T1(i, j + 1)
        dico(T1(i, j)) = T2
    Next
Next
With Worksheets("Résultat")
.Range("A10").Resize(dico.Count, 1) = Application.Transpose(dico.keys)
.Range("B10").Resize(dico.Count, Maxi) = Application.Transpose(Application.Transpose(dico.items))
End With
End Sub

pas pu comparer la rapidité, avec XL2003 j'ai des temps de 0.2 secondes mais avec 256 colonnes !

adapter les noms de feuilles et l'emplacement des données

A+

 

[job75]

Re, hello Paf,

En concaténant les n° de ligne et colonne c'est nettement plus rapide :

Private Sub Worksheet_Activate()
Dim P As Range, ncol%, t, d As Object, d1 As Object, i&, j%, x$, a, b, resu(), e, n As Byte, lig&, col%
Application.ScreenUpdating = False
Cells.ClearContents 'RAZ
Set P = Feuil1.[A1].CurrentRegion 'CodeName Feuil1
ncol = Application.Ceiling(P.Columns.Count, 2) 'sécurité (nombre pair)
t = P.Resize(, ncol)
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
'---liste des noms sans doublon et concaténation n° ligne et colonne---
For i = 2 To UBound(t)
  d1.RemoveAll 'RAZ à chaque ligne
  For j = 1 To ncol Step 2
    x = t(i, j)
    If x <> "" Then
      d(x) = d(x) & "." & IIf(d1.exists(x), "", i & " ") & j + 1
      d1(x) = ""
    End If
Next j, i
If d.Count = 0 Then GoTo 1
'---tableau des résultats---
a = d.keys: b = d.items
ReDim resu(1 To d.Count + 1, 1 To 1 + ncol / 2)
For i = 0 To UBound(a)
  resu(i + 2, 1) = a(i)
  For Each e In Split(Mid(b(i), 2), ".")
    n = InStr(e, " ")
    If n Then lig = Left(e, n)
    col = Mid(e, n + 1)
    resu(i + 2, 1 + col / 2) = t(lig, col)
Next e, i
'---titres---
resu(1, 1) = "Nom"
For j = 2 To UBound(resu, 2)
  resu(1, j) = t(1, 2 * j - 3)
Next
'---restitution---
[A1].Resize(UBound(resu), UBound(resu, 2)) = resu
1 Columns.AutoFit 'ajustement largeur
With Me.UsedRange: End With 'actualisation des barres de défilement
End Sub

Fichiers joints, pour le 2ème fichier durée d'exécution 0,87 seconde (durée stable).

Edit : j'ai ajouté un 2ème Dictionary, ce qui a fait gagner 20%.

A+

 

[Paf]

re,

s'il n'y a pas plus de données pour un individu que le nombre de colonne/2, une autre version qui évite le balayage du tableau par deux boucles imbriquées et un balayage du dico. on doit gagner quelques millièmes...

Sub TransP()
Dim dico, i As Long, j As Long, T1, T2, T3,  Maxi As Long
Set dico = CreateObject("Scripting.Dictionary")
'T1 = Worksheets("Feuille1").Range("A1").CurrentRegion
T1 = Worksheets("Base").Range("A1").CurrentRegion
Maxi = (UBound(T1, 2) / 2) - 1
ReDim T2(0 To Maxi)
T3 = T2
For j = LBound(T1, 2) To UBound(T1, 2) Step 2
    For i = LBound(T1, 1) To UBound(T1, 1)
        If Not dico.Exists(T1(i, j)) Then dico(T1(i, j)) = T3
        T2 = dico(T1(i, j))
        T2(((j + 1) / 2) - 1) = T1(i, j + 1)
        dico(T1(i, j)) = T2
    Next
Next
With Worksheets("Résultat")
.Range("A10").Resize(dico.Count, 1) = Application.Transpose(dico.keys)
.Range("B10").Resize(dico.Count, Maxi) = Application.Transpose(Application.Transpose(dico.items))
End With
End Sub

A+