Aligner des lignes en fonction d'une valeur

Le 20/05/2015 à 11:54

Bonjour,

Ceci est mon premier message sur un forum informatique, n'hésitez pas à me dire s'il manque des choses dans mon message ! Je vous remercie d'avance pour votre aide qui pourra me faire gagner des jours entiers !

J'ai deux tableau comme dans le fichier joins au message sous Excel 2010 FR.

L'onglet "Données" représente des acides gras (=lipides=espèces de gras) dont la veleur quantitative est la colonne "aire" et l'identification de l'échantillon la colonne "échantillon". Le nombre d'échantillon peut varier de 5 à 500.

L'onglet "Bilan" représente la forme finale sous laquelle ces données doivent être présentées (pour différents soucis de traitement ultérieurs).

Dans l'onglet bilan, j'ai inséré manuellement les données, comme vous pouvez le voir le temps perdu vient du fait que chaque échantillon ne possède pas tous les acides gras présents dans le tableau bilan (cela veut dire qu'ils ne sont pas présent dans mon échantillon de tissu), je ne peux donc pas faire un simple copier-coller.

Je recherche donc une méthode pour "aligner" pour chaque échantillon les lignes colonnes de l'onglet "donnees" avec la colonne "acides gras" de l'onglet "bilan".

Quelques informations pratiques :

  • on peut remplacer les noms des acides gras par quelque chose de plus simple
  • les cellules vides du tableau bilan peuvent afficher 0 ou être vides (0 ça m'arrange )
  • les deux tableaux peuvent être sur la même feuille si besoin
  • si possible il faudrait que les cellules soient copiées avec leur commentaire.

J'espère avoir tout dit et qu'une solution existe !

Merci d'avance et bonne journée !

Gaëtan

41test-acide-gras-forum.xlsx (15.55 Ko)
Le 20/05/2015 à 13:02

Bonjour,

Une proposition

A+

64test-acide-gras-forum.xlsx (16.39 Ko)
Le 20/05/2015 à 13:42

Bonjour,

Une proposition par macro.

Nombre d'échantillons extensibles et triés par ordre croissant

43test-acide-gras-forum.xlsm (24.58 Ko)
Le 20/05/2015 à 19:03

a

Le 21/05/2015 à 13:24
Fred35 a écrit :

Bonjour,

Une proposition par macro.

Nombre d'échantillons extensibles et triés par ordre croissant

Bonjour,

Je me permet de rouvrir le sujet car il me manque juste un petit point dans la macro !!

Sauriez-vous comment faire pour copier les commentaires des cellules en même temps que les cellules svp?

Merci beaucoup !

Gaëtan

Le 21/05/2015 à 17:59

Bonjour à tous,

Restitution dans la feuille "donnees" à côté du tableau initial.

Pour les commentaires, je ne sais pas faire 

Option Explicit

Sub ventile()
Dim a, i As Long, AL As Object, e
    Application.ScreenUpdating = False
    Set AL = CreateObject("System.Collections.ArrayList")
    With Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(3, 1, 2))
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Not AL.Contains(a(i, 2)) Then AL.Add a(i, 2)
                If Not .exists(a(i, 1)) Then
                    Set .Item(a(i, 1)) = _
                    CreateObject("Scripting.Dictionary")
                End If
                .Item(a(i, 1))(a(i, 2)) = a(i, 3)
            Next
            AL.Sort
            ReDim a(1 To .Count + 1, 1 To AL.Count + 1)
            a(1, 1) = "Acide gras"
            For i = 0 To AL.Count - 1
                a(1, i + 2) = AL(i)
            Next
            For i = 0 To .Count - 1
                a(i + 2, 1) = .keys()(i)
                For Each e In .items()(i).keys
                    a(i + 2, AL.IndexOf(e, 0) + 2) = IIf(.items()(i)(e) <> 0, .items()(i)(e), "")
                Next
            Next
        End With
        With .Offset(, .Columns.Count + 2)
            .CurrentRegion.Clear
            .Cells(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
            With .CurrentRegion
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .BorderAround ColorIndex:=1, Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                With .Rows(1)
                    .Offset(, 1).Resize(, .Columns.Count - 1).Interior.ColorIndex = 40
                    .BorderAround ColorIndex:=1, Weight:=xlThin
                End With
                .Columns(1).Offset(1).Resize(.Rows.Count - 1).Interior.ColorIndex = 19
                On Error Resume Next
                .SpecialCells(4) = 0
                On Error GoTo 0
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 24/05/2015 à 02:53

Bonjour,

Fichier incluant mise en forme, tableau dans la feuille bilan en fonction des acides de la colonne A + report des commentaires.

J'ai également supprimé le module et mis le code dans les boutons de la feuille "donnees".

Le code du tableau :

Private Sub CommandButton2_Click()
' Création du tableau bilan
Dim plage()
Dim i As Variant
Dim Dico As Object
Dim NbLigne As Long, NbColonne As Long
Dim Result As Range
Dim Ws As Worksheet

Application.ScreenUpdating = False

Set Dico = CreateObject("Scripting.Dictionary")
Set Ws = Sheets("bilan")
Set Result = Ws.Cells(2, 2)

'Suppression des commentaires dans la feuille
Sheets("Bilan").Cells.ClearComments

With Sheets("Donnees")
    NbLigne = .Range("A1").End(xlDown).Row
    plage = .Range("A2:A" & NbLigne).Value
    For Each i In plage
       Dico(i) = ""
    Next i
    Result.Resize(1, Dico.Count) = Dico.keys
    Result.Resize(1, Dico.Count).Sort Key1:=Result, Order1:=xlAscending, Orientation:=xlLeftToRight
    Set Dico = Nothing

    For NbColonne = 2 To Result.End(xlToRight).Column
        For i = 4 To 32
            For NbLigne = 2 To .Range("A1").End(xlDown).Row
                If .Cells(NbLigne, 1) = Ws.Cells(2, NbColonne) Then
                    If Ws.Cells(i, 1) = .Cells(NbLigne, 3) Then
                        Ws.Cells(i, NbColonne) = .Cells(NbLigne, 2)
                        If Not .Cells(NbLigne, 2).Comment Is Nothing Then 'vérifie la présence d'un commentaire
                            Ws.Cells(i, NbColonne).AddComment 'Ajoute un commentaire
                            Ws.Cells(i, NbColonne).Comment.Visible = False 'Non visible en permanence
                            Ws.Cells(i, NbColonne).Comment.Text Text:="" & .Cells(NbLigne, 2).Comment.Text 'Nouveau commentaire = ancien commentaire
                        End If
                    End If
                End If
            Next NbLigne
        Next i
    Next NbColonne
End With

Application.ScreenUpdating = True

End Sub

Le code pour la mise en forme :

Private Sub CommandButton1_Click()
' Colorier les doublons
Dim Col1 As Object, Col2 As Object
Dim c As Range

Application.ScreenUpdating = False

With Sheets("donnees")
  .Cells(1, 1).CurrentRegion.Interior.ColorIndex = xlNone
  Set Col1 = CreateObject("Scripting.Dictionary")
  Set Col2 = CreateObject("Scripting.Dictionary")
  For Each c In .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    Col1.Item(c.Value & c.Offset(, 1)) = Col1.Item(c.Value & c.Offset(, 1)) + 1
    Col2.Item(c.Value & c.Offset(, 1)) = Col2.Item(c.Value & c.Offset(, 1)) & CStr(c.Row) & "-"
  Next c
  For Each c In .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    If Col1.Item(c.Value & c.Offset(, 1)) > 1 Then
       c.Resize(, 3).Interior.ColorIndex = (Application.Match(c.Value & c.Offset(, 1), Col1.keys, 0) + 2) Mod 55
     End If
   Next c
End With

Application.ScreenUpdating = True

End Sub
26mise-en-forme-doublon-ag-vba.xlsm (45.15 Ko)
Rechercher des sujets similaires à "aligner lignes fonction valeur"