Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 [RESOLU] extraction complexe sur une autre feuille

ivan27

XLDnaute Occasionnel
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
 

Pièces jointes

  • bd.xlsx
    80.8 KB · Affichages: 29

youky(BJ)

XLDnaute Barbatruc
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
 

Pièces jointes

  • BDessai.xlsm
    86.7 KB · Affichages: 22

ivan27

XLDnaute Occasionnel
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)

XLDnaute Barbatruc
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
 

Pièces jointes

  • BDessai.xlsm
    88.4 KB · Affichages: 33

youky(BJ)

XLDnaute Barbatruc
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)

XLDnaute Barbatruc
Encore un mot,
j'ai vu que j'avais parfois une ligne en trop
je rectifie avec cette nouvelle macro.
Bruno
VB:
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

XLDnaute Occasionnel
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)

XLDnaute Barbatruc
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

VB:
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
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…