"Chainer" 2 lignes en une seule selon plusieurs critères

[Nurbo]

Bonjour tout le monde,


Aller, une p'tite galère et là je ne vois pas sur quelle piste partir. Mon niveau en VBA est débutant ++ et je sais bidouiller en testant les morceaux de code que je trouve par ci par là (par toujours très orthodoxe mais ça fonctionne)

Bref, je vous explique mon problème.

Je fais une extraction via un requêteur (Brio d'Hypérion) et il me sort un fichier de x lignes (exemple dans le fichier joint).

Les résultats de la requête me donne plusieurs informations, mais elles sont sur deux lignes, avec une heure de début une heure de fin + d'autres paramètres.
Le but étant de rassembler ces informations en se basant sur le nom de la chaîne (col.B), pour ensuite créer une sorte de planning de production.

Comme vous le savez ce n'est pas facile d'expliquer ce que l'on souhaite, je vous ai donc fait un fichier avec explications et code couleur.

J'ai indiqué Excel 2003 mais j'ai un deuxième PC sous Excel 2010.


Je vous remercie pas avance.



Nurbo

 

[Paritec]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Bonjour Nurbo,
Ton fichier en retour avec un petit bouton tu cliques et tu as le résultat
a+
Papou

 

[Paritec]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Re Bonjour Nurbo,
bon j'ai rajouté un bouton pour effacer le planning pour tes tests
a+
papou

 

[job75]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Bonjour Nurbo, salut Papou

Une solution très rapide sur une grande BDD car elle utilise des tableaux VBA :

Sub Rassembler()
Dim plage As Variant, tablo()
Application.ScreenUpdating = False
Set plage = [A5].CurrentRegion.Offset(1)
[22:65536].Delete xlUp 'RAZ
plage.Copy [A22] 'où l'on veut, éventuellement dans une autre feuille...
Set plage = [A22].Resize(plage.Rows.Count, plage.Columns.Count)
plage.Columns(6).Insert xlToRight 'une colonne de plus
ReDim tablo(1 To plage.Rows.Count - 1, 1 To plage.Columns.Count)
plage = plage 'matrice, plus rapide
For i = 1 To UBound(tablo)
  tablo(i, 1) = plage(i, 1)
  tablo(i, 2) = plage(i, 2)
  tablo(i, 3 - 2 * (plage(i, 4) = "Fin")) = plage(i, 3)
  tablo(i, 4 - 2 * (plage(i, 4) = "Fin")) = Format(plage(i, 7), "hh:mm")
  tablo(i, 7) = plage(i, 5)
  If plage(i, 2) = plage(i + 1, 2) Then
    tablo(i, 5) = plage(i + 1, 3)
    tablo(i, 6) = Format(plage(i + 1, 7), "hh:mm")
    i = i + 1
  End If
Next
'---restitution---
With [A22].Resize(UBound(tablo), 7)
  .Value = tablo
  On Error Resume Next
  .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Bien noter que la restitution se fait en A22 mais qu'on peut la faire où l'on veut, par exemple dans une autre feuille.

Fichier joint.

A+

 

[job75]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Re,

Cette macro est bien mieux construite :

Sub Rassembler()
Dim plage As Variant, tablo()
plage = [A5].CurrentRegion.Offset(1) 'matrice, plus rapide
ReDim tablo(1 To UBound(plage), 1 To 7)
For i = 1 To UBound(tablo) - 1
  tablo(i, 1) = plage(i, 1)
  tablo(i, 2) = plage(i, 2)
  tablo(i, 3 - 2 * (plage(i, 4) = "Fin")) = plage(i, 3)
  tablo(i, 4 - 2 * (plage(i, 4) = "Fin")) = Format(plage(i, 6), "hh:mm")
  tablo(i, 7) = plage(i, 5)
  If plage(i, 2) = plage(i + 1, 2) Then
    tablo(i, 5) = plage(i + 1, 3)
    tablo(i, 6) = Format(plage(i + 1, 6), "hh:mm")
    i = i + 1
  End If
Next
'---restitution en [A22] (mais on peut le faire dans une autre feuille)---
Application.ScreenUpdating = False
[22:65536].Delete 'RAZ
Set plage = [A22].Resize(UBound(plage), 7)
[A6].Resize(plage.Rows.Count).Copy plage 'pour les couleurs
plage.Columns("C:G").HorizontalAlignment = xlCenter 'centrage (facultatif)
plage.Value = tablo 'restitution des valeurs
On Error Resume Next
plage.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

J'en profite pour centrer les colonnes C:G.

Fichier (2).

A+

 

[Paritec]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Bonjour Nurbo Job
oui mais moi job je lui fais le planning directement normal que ce soit un tantinet plus long en macro
a+
papou

 

[job75]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Re Papou,

Oui, tu as bien fait, moi j'ai compris que Nurbo saurait se débrouiller tout seul avec le nouveau tableau qu'il a demandé.

Au cas où il n'y arrive pas, voici le code à ajouter à la fin de ma macro :

'---planning---
With Sheets("planche")
  .[2:65536].Clear 'RAZ
  plage.Columns(1).Copy .[A2]
  For i = 1 To plage.Rows.Count
    col1 = Application.Match(ref.Offset(i, 3) + 1 / 86400, .[1:1])
    If IsNumeric(col1) Then .Cells(i + 1, col1) = ref.Offset(i, 2)
    col2 = Application.Match(ref.Offset(i, 5) + 1 / 86400, .[1:1])
    .Cells(i + 1, col2) = ref.Offset(i, 4)
    If IsError(col1) Then col1 = col2
    .Range(.Cells(i + 1, col1), .Cells(i + 1, col2)).Interior.Color _
      = .Cells(i + 1, 1).Interior.Color
  Next
  .[B:CT].EntireColumn.AutoFit 'ajuste les largeurs des colonnes
  .Activate 'facultatif
End With

J'ai défini ref plus haut.

Fichier (3).

Edit : On Error Resume Next était inutile car la dernière ligne de tablo est toujours vide.

A+

 

[Nurbo]

Re : "Chainer" 2 lignes en une seule selon plusieurs critères

Merci à tous pour vos réponses !!!

Je n'ai qu'une chose à dire, vous êtes des extra-terrestre

C'est dommage, j'ai pas fait gaffe que vous m'aviez répondu sinon j'aurais pris une extraction pour tester ça ce week-end.

Je vais quand même jeter un oeil après manger (les gosses, le bain, la bouffe....) je vous fais pas de dessin

Je reviens tout à l'heure.


@+


et encore mille merci !