Recherche page, si compris dans la base
S
Bonjour,
Dans le fichier ci-joint, je souhaite extraire les titres en fonction de la page.
Sauf que j'ai un onglet 'Page' qui précise :
- De manière unique : je n'ai pas de problème
- Par plage de page, exemple de la page 268-286 = "Doghnmo" pour les deux pages 268 ET 286
- Différent notion par exemple "129 à 151" : Toutes les pages entre 129 et 151
Enfin pour complexifier encore, je peux avoir deux titres sur une même page, dans ce cas il faut retourner les deux valeurs.
Les données sont à mettre dans l'onglet "BASE" en fonction du n° de page
Bonjour Snooper, bonjour le forum,
En pièce jointe ton fichier avec un bouton qui prend l'extension xlsm à cause du code VBA.
J'ai testé sur quelques lignes avec plusieurs cas et ça semble bien fonctionner.
Le code :
Option Explicit
Sub Macro1()
Dim OP As Worksheet 'déclare la variable OP (Onglet Page)
Dim OB As Worksheet 'déclare la variable OB (Onglet Base)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NB As Integer 'déclare la variable NB (NomBre)
Dim NBT As Integer 'déclare la variable NBT (NomBre de Tirets)
Dim NBA As Integer 'déclare la variable NBA (NomBre de à)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim LI As Integer 'déclare la variable LI (LIgne)
Dim LID As Integer 'déclare la variable LID (LIgne de Début)
Dim LIF As Integer 'déclare la variable LIF (LIgne de Fin)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim P As Integer 'déclare la variable P (Page)
Dim T As String 'déclare la variable T (Texte)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OP = Worksheets("Page") 'définit l'onglet OP
Set OB = Worksheets("Base") 'définit l'onglet OB
OB.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface les anciennes valeurs de l'onglet OB
TV = OP.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
'************************
'récupération des données
'************************
For I = 2 To UBound(TV, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
'condition 1 : si la donnée ligne I colonne 2 de TV contient un (ou plusieurs) tirets et aussi un (ou plusieurs) "à"
If InStr(1, TV(I, 2), "-", vbTextCompare) <> 0 And InStr(1, TV(I, 2), "à", vbTextCompare) <> 0 Then
NBT = UBound(Split(TV(I, 2), "-")) 'définit le nombre de tirets NBT dans la donnée ligne I colonne 2 de TV
For J = 0 To NBT 'boucle 2 : sur J fois de 0 au nombre de tirets NBT
'définit le nombre de "à" dans la partie avant, entre ou après le tiret (en fonction de J) de la donnée ligne I colonne 2 de TV
NBA = UBound(Split(Split(TV(I, 2), "-")(J), "à"))
If NBA > 0 Then 'condition 2 : si le nombre de "à" NBA est supérieur à zéro
For K = 0 To NBA Step 2 'boucle 3 : sur K fois de 0 au nombre NBA par pas de deux
'définit la ligne de début LID (partie avant le "à" sans espaces, convertie en entier)
LID = CInt(Trim(Split(Split(TV(I, 2), "-")(J))(K)))
'définit la ligne de fin LIF (partie après le "à" sans espaces, convertie en entier)
LIF = CInt(Trim(Split(Split(TV(I, 2), "-")(J), "à")(K + 1)))
For L = LID To LIF 'boucle 4 : de la ligne de début LID à la ligne de fin LIF
OB.Cells(L + 1, 1).Value = L 'renvoie dans la cellule ligne L + 1 colonne 1 de l'onglet OB le numéro de page égal à L
'renvoie dans la cellule ligne L + 1, colonne 2 de l'onglet OB, le titre si cette cellule est vide,
'sinon renvoie la valeur de la cellule plus le titre, séparés par "***"
OB.Cells(L + 1, 2) = IIf(OB.Cells(L + 1, 2).Value = "", TV(I, 1), OB.Cells(L + 1, 2).Value & "***" & TV(I, 1))
Next L 'prochaine ligne de la boucle 4
Next K 'prochaine nombre de "à" (par pas de deux)
Else 'sinon (condition 2)
LI = CInt(Trim(Split(TV(I, 2), "-")(J))) 'définit la ligne LI (valeur avant, entre ou après le tiret (en fonction de J))
OB.Cells(LI + 1, 1).Value = LI 'renvoie le numéro de page dans la cellule ligne LI + 1 colonne 1 de l'onglet OB
'renvoie dans la cellule ligne LI + 1, colonne 2 de l'onglet OB le titre si cette cellule est vide,
'sinon renvoie la valeur de la cellule plus le titre, séparés par "***"
OB.Cells(LI + 1, 2) = IIf(OB.Cells(LI + 1, 2).Value = "", TV(I, 1), OB.Cells(LI + 1, 2).Value & "***" & TV(I, 1))
End If 'fin de la condition 2
Next J 'prochaine tiret de la boucle 2
'condition 1 : si la donnée ligne I colonne 2 de TV contient un (ou plusieurs) tirets
ElseIf InStr(1, TV(I, 2), "-", vbTextCompare) <> 0 Then
NBT = UBound(Split(TV(I, 2), "-")) 'définit le nombre de tirets NBT dans la donnée ligne I colonne 2 de TV
For J = 0 To NBT 'boucle 2 : sur J fois de 0 au nombre de tirets NBT
LI = CInt(Trim(Split(TV(I, 2), "-")(J))) 'définit la ligne LI (valeur avant, entre ou après le tiret (en fonction de J))
OB.Cells(LI + 1, 1).Value = LI 'renvoie le numéro de page dans la cellule ligne LI + 1 colonne 1 de l'onglet OB
'renvoie dans la cellule ligne LI + 1, colonne 2 de l'onglet OB le titre si cette cellule est vide,
'sinon renvoie la valeur de la cellule plus le titre, séparés par "***"
OB.Cells(LI + 1, 2) = IIf(OB.Cells(LI + 1, 2).Value = "", TV(I, 1), OB.Cells(LI + 1, 2).Value & "***" & TV(I, 1))
Next J 'prochain tiret de la boucle 2
'condition 1 : si la donnée ligne I colonne 2 de TV contient un (ou plusieurs) "à"
ElseIf InStr(1, TV(I, 2), "à", vbTextCompare) <> 0 Then
NBA = UBound(Split(TV(I, 2), "à")) 'définit le nombre de "à" NBA dans la donnée ligne I colonne 2 de TV
For J = 0 To NBA Step 2 'boucle 2 : sur J fois de 0 au nombre NBA
'définit la ligne de début LID (partie avant le "à" sans espaces, convertie en entier)
LID = CInt(Trim(Split(TV(I, 2), "à")(J)))
'définit la ligne de fin LIF (partie après le "à" sans espaces, convertie en entier)
LIF = CInt(Trim(Split(TV(I, 2), "à")(J + 1)))
For K = LID To LIF 'boucle 3 : sur toutes les lignes K de LID à LIF
OB.Cells(K + 1, 1).Value = K 'renvoie le numéro de page égale à K dans la cellule ligne K + 1 colonne 1 de l'onglet OB
'renvoie dans la cellule ligne K + 1, colonne 2 de l'onglet OB le titre si cette cellule est vide,
'sinon renvoie la valeur de la cellule plus le titre, séparés par "***"
OB.Cells(K + 1, 2) = IIf(OB.Cells(K + 1, 2).Value = "", TV(I, 1), OB.Cells(K + 1, 2).Value & "***" & TV(I, 1))
Next K 'prochaine ligne de la boucle 3
Next J 'prochain "à" de la boucle 2
Else 'sinon (condition 1), la donnée ligne I colonne 2 de TV ne contient ni tiret ni "à"
OB.Cells(TV(I, 2) + 1, 1).Value = TV(I, 2) 'renvoie le numéro de page TV(I,1) dans la cellule ligne TV(I, 1) + 1 colonne 1 de l'onglet OB
'renvoie dans la cellule ligne TV(I, 1) + 1, colonne 2 de l'onglet OB le titre si cette cellule est vide,
'sinon la renvoie valeur de la cellule plus le titre, séparés par "***"
OB.Cells(TV(I, 2) + 1, 2) = IIf(OB.Cells(TV(I, 2) + 1, 2).Value = "", TV(I, 1), OB.Cells(TV(I, 2) + 1, 2).Value & "***" & TV(I, 1))
End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle 1
'******************************************************************************************
'Suppression des lignes vides et ajout de lignes quand plusieurs titres, séparés par "***"
'******************************************************************************************
DL = OB.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OB
For I = DL To 2 Step -1 'boucle inversée sur toutes les lignes I de l'onglet OB, de la dernière DL à la seconde, en remontant
If OB.Cells(I, "A") = "" Then OB.Rows(I).Delete 'si la valeur de la cellule ligne I colonne A de l'onglet OB est vide, supprime la ligne I
Next I 'prochaine ligne (en remontant)
TV = OB.Range("A1").CurrentRegion 'redéfinit le tableau des valeurs TV
For I = UBound(TV, 1) To 2 Step -1 'boucle 1 : inversée sur toutes les lignes I du tableau des valeurs TV, de la dernière DL à la seconde, en remontant
P = TV(I, 1) 'définit la page P de la donnée ligne I colonne 1 de TV
T = TV(I, 2) 'définit le texte T de la données ligne I colonne 2 de TV
NB = UBound(Split(TV(I, 2), "***")) 'définit le nombre de fois NB que "***" apparaît dans la donnée ligne I colonne 2 de TV
If NB > 0 Then 'condition si NB est supérieure à zéro
For J = 0 To NB 'boucle 2 : sur J fois de 0 à NB
OB.Rows(I).Insert shift:=xlUp 'insère une ligne au-dessus
OB.Cells(I, "A").Value = P 'renvoie la page P dans la ligne insérée colonne A
OB.Cells(I, "B").Value = Split(T, "***")(J) 'renvoie le texte avant, entre ou après "***" (en fonction de J) dans la ligne insérée colonne B
Next J 'prochain "***" de la boucle 2
OB.Rows(I + NB + 1).Delete 'efface la ligne I + NB (qui contenait le texte concaténé)
End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1 (en remontant)
MsgBox "Données traitées !" 'message
OB.Activate 'active l'onglet OB
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End SubLe fichier :
S
Bonjour ThauThème,
Je te remercie du temps passé pour ma demande, et les annotations sont précieuses pour ma compréhension.
Je vais de ce pas avancée sur mon fichier.
Encore merci pour le travail fourni, vraiment top.