XL 2016 [RESOLU] extraction complexe sur une autre feuille

[ivan27]

Bonjour à tous,

J'ai une extraction complexe a effectuer et je n'y arrive pas seul.

Lorsque j'exporte mes contacts, au format excel, depuis mon logiciel métier, j'obtiens une liste dans laquelle un contact est représenté sur plusieurs lignes.

Le résultat de l'extraction est difficilement exploitable. Voir exemple joint avec des données fantaisistes.

Toutes les lignes concernant un même contact sont facilement repérables en colonne A.
La fiche d'un contact commence par "CH" et se termine juste avant le "CH" suivant.

Le type est renseigné en colonne J sur les lignes qui commencent par CT

Un même contact peux avoir plusieurs types séparés par des virgules.

J'ai besoin d'extraire mes contacts par type.

Idéalement, il faudrait extraire sur une autre feuille toutes les lignes commencant par CH (colonnes B à M) et à la suite la ligne commençant par CT (colonne B à M).

Si un contact à plusieurs types, alors faire autant d'extractions que de types.

La colonne A est toujours renseignée par contre beaucoup de données peuvent être absentes sur les autres colonnes.

Le fichier d'origine fait environ 7000 lignes et compte 33 colonnes.

J'ai reproduit manuellement le résultat attendu sur quelques lignes de l'onglet "Resultat_Attendu".

Merci d'avance pour votre aide.

Ivan

 

[youky(BJ)]

Bonjour Ivan,
Voici de retour le fichier en xlsm puisqu'il contient une macro "recopie"
à exécuter avec le menu Macro.
Dans l'exemple j'ai ajouté un onglet pour le test, j'utilise comme nom de page en macro le CodeName
qui est Feuil3 et non le nom mis en bas de la page donc il conviendra de remplacer Feuil3 par le bon N°
voir en VBA fenêtre des projets.
Si besoin d'utiliser l'onglet Résultat Attendu c'est Feuil2 qu'il faudra mettre au lieu Feuil3
Pensez à activer les macros
Bruno

 

[ivan27]

Bonjour Bruno, et rebonjour le forum,
Merci beaucoup pour cette proposition.
lorsque sur une même ligne il y a plusieurs types comme par exemple la ligne 175 qui a les types sav,pro,gtr
Est-il possible d'obtenir 3 lignes différentes dans l'extraction ?
Ivan

 

[youky(BJ)]

Ben voila,
Y a plus qu'à . . . .
A chaque ligne en plus j'ai mis le détail c'est à dire...
sav pour la 1ere ligne
pro pour la seconde
gtr pour la troisième
bruno

 

[ivan27]

Re bonjour Bruno, le forum,
Tout simplement génial.
Je vous réitère mes remerciements.
Bonne fin de week-end
Ivan

 

[youky(BJ)]

re,
J'ai oublié d'enlever des variables dans la macro qui ne servent à rien.
Ce qui est en rouge peut être supprimé
Sub recopie()
Feuil3.Cells.Clear 'on efface tout
bas = Feuil1.[A65000].End(3).Row
For lig = 1 To bas
If Feuil1.Cells(lig, 1) = "CH" Then
lg = lg + 1
'copie de A à L
Feuil3.Range("A" & lg & ":L" & lg).Value = Feuil1.Range("B" & lig & ":M" & lig).Value
End If
If Feuil1.Cells(lig, 1) = "CT" Then
lg = lg + 1
'copie de A à L et M à X
Feuil3.Range("A" & lg & ":L" & lg).Value = Feuil3.Range("A" & lg - 1 & ":L" & lg - 1).Value
Feuil3.Range("M" & lg & ":X" & lg).Value = Feuil1.Range("B" & lig & ":M" & lig).Value
If Feuil3.Cells(lg, 21) Like "*,*" Then
nl = UBound(Split(Feuil3.Cells(lg, 21), ",", -1, vbTextCompare))
deb = lg + 1: fin = lg + nl + 1: tx = Feuil3.Cells(lg, 21): n = 0
Feuil3.Cells(lg, 21) = Split(tx, ",")(0)
For k = lg + 1 To lg + nl
Feuil3.Range("A" & k & ":X" & k).Value = Feuil3.Range("A" & k - 1 & ":X" & k - 1).Value
n = n + 1: Feuil3.Cells(k, 21) = Split(tx, ",")(n)
lg = lg + 1
Next
End If
End If
Next
'End If
End Sub

 

[youky(BJ)]

Encore un mot,
j'ai vu que j'avais parfois une ligne en trop
je rectifie avec cette nouvelle macro.
Bruno

Sub recopie()
Feuil3.Cells.Clear 'on efface tout
bas = Feuil1.[A65000].End(3).Row
For lig = 1 To bas
If Feuil1.Cells(lig, 1) = "CH" Then
lg = lg + 1: bb = 0
  'copie de A à L
Feuil3.Range("A" & lg & ":L" & lg).Value = Feuil1.Range("B" & lig & ":M" & lig).Value
End If
If Feuil1.Cells(lig, 1) = "CT" Then
 'copie de A à L et M à X
If bb > 0 Then
lg = lg + 1
Feuil3.Range("A" & lg & ":L" & lg).Value = Feuil3.Range("A" & lg - 1 & ":L" & lg - 1).Value
End If
Feuil3.Range("M" & lg & ":X" & lg).Value = Feuil1.Range("B" & lig & ":M" & lig).Value
bb = bb + 1
If Feuil3.Cells(lg, 21) Like "*,*" Then
nl = UBound(Split(Feuil3.Cells(lg, 21), ",", -1, vbTextCompare))
deb = lg + 1: fin = lg + nl + 1: tx = Feuil3.Cells(lg, 21): n = 0
Feuil3.Cells(lg, 21) = Split(tx, ",")(0)
For k = lg + 1 To lg + nl
Feuil3.Range("A" & k & ":X" & k).Value = Feuil3.Range("A" & k - 1 & ":X" & k - 1).Value
n = n + 1: Feuil3.Cells(k, 21) = Split(tx, ",")(n)
lg = lg + 1
Next
End If
End If
Next
End Sub

 

[ivan27]

Ok je corrige.
Merci Bruno

 

[ivan27]

Bonjour Bruno, le forum,
Je viens de tester en production et ce code fonctionne parfaitement lorsqu'il est placé dans un module du classeur concerné par la recopie.
Cependant, le code ne fonctionne pas depuis un module de PERSONAL.XLSB.
Est-il possible de remédier à ce problème sans trop de difficulté ?
Bien cordialement et bonne journée.
Ivan

 

[youky(BJ)]

Bonjour Ivan,
De la veine que je passe ici juste à temps.
Dans la macro j'utilise Sheets(1) qui est le 1er onglet et Sheets(2) le 2ème onglet
Possible de mettre le nom de cette façon au lieu Sheet(1) mettre Sheets("origine")
Ps:NON testé en Perso
Bruno

Sub recopie()
With ActiveWorkbook
.Sheets(2).Cells.Clear 'on efface tout
bas = .Sheets(1).[A65000].End(3).Row
For lig = 1 To bas
If .Sheets(1).Cells(lig, 1) = "CH" Then
lg = lg + 1: bb = 0
  'copie de A à L
.Sheets(2).Range("A" & lg & ":L" & lg).Value = .Sheets(1).Range("B" & lig & ":M" & lig).Value
End If
If .Sheets(1).Cells(lig, 1) = "CT" Then
'copie de A à L et M à X
If bb > 0 Then
lg = lg + 1
.Sheets(2).Range("A" & lg & ":L" & lg).Value = .Sheets(2).Range("A" & lg - 1 & ":L" & lg - 1).Value
End If
.Sheets(2).Range("M" & lg & ":X" & lg).Value = .Sheets(1).Range("B" & lig & ":M" & lig).Value
bb = bb + 1
If .Sheets(2).Cells(lg, 21) Like "*,*" Then
nl = UBound(Split(.Sheets(2).Cells(lg, 21), ",", -1, vbTextCompare))
tx = .Sheets(2).Cells(lg, 21): n = 0
.Sheets(2).Cells(lg, 21) = Split(tx, ",")(0)
For k = lg + 1 To lg + nl
.Sheets(2).Range("A" & k & ":X" & k).Value = .Sheets(2).Range("A" & k - 1 & ":X" & k - 1).Value
n = n + 1: .Sheets(2).Cells(k, 21) = Split(tx, ",")(n)
lg = lg + 1
Next
End If
End If
Next
End With
End Sub