XL 2019 séparer le nom et le numéro de chambre

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
E

escudo

XLDnaute Junior
Bonsoir à tous,


J'ai un problème avec un code VBA qui fonctionne très bien pour l'extraction des données, mais j'aimerais qu'il sépare le nom et le numéro de chambre. Le nom devrait être placé dans la colonne A et le numéro de chambre dans la colonne B.


Merci d'avance pour votre aide !
 

Pièces jointes

Solution
job75
Bonjour escudo, le forum,

Ce n'était pas fini, marquez plutôt ce post comme solution, la macro s'exécute en 1,4 seconde chez moi :
VB: 
Sub Extraction()
Dim DL&, tablo, a(), i&, n&, sejour As Range, x$, y As Variant, s, ub%, hTVA As Variant, b, ii&, jj%, j%
With Sheets("FACTURES")
    DL = .Cells(.Rows.Count, 1).End(xlUp).Row 'dernière ligne
    tablo = .Range("A1:A" & DL + 1) 'matrice, plus rapide, au moins 2 éléments
    ReDim a(1 To DL, 1 To 7)
    For i = 1 To DL
        If UCase(Left(tablo(i, 1), 6)) = "SEJOUR" Then
            n = n + 1
            Set sejour = .Cells(i, 1)
            x = tablo(i, 1) & "/"
            a(n, 1) = Trim(Mid(x, 9, InStr(x, "/") - 9)) 'nom
            x = "/ CHB"
            y =...
Trier par date Trier par votes
Bonjour le Fil
escudo
quelle est la bonne présentation de tes Factures : 5 colonnes de A à E ou 6 colonnes de A à F car dans ton fichier du #9 tu as les deux version !
je crois que Gérard a Corrigé ,mais est ce la Bonne solution (c'est suite à une erreur ) , ou est ce la présentation qui est comme cela ?
bonne Journée
Jean marie
 
Vote positif 0 Vote négatif
Bonsoir à toutes & à tous, bonsoir @escudo

Un peu tard comme toujours mais voici une proposition avec les résultats dans un Tableau Structuré ("TS_Factures") sur la feuille "Résultat".

J'ai étendu la feuille "FACTURES" à un peu plus de 1300 lignes pour avoir une idée du temps d'exécution. Avec un nombre de lignes plus important et plus d'infos ramenées, c'est un peu plus rapide que la proposition de @job75 (si étendue aussi à un peu plus de 1300 lignes).

Je teste l'existence des lignes d'entête des factures car dans le fichier fourni au post #9 (01062022.xlsm) certains de ces entêtes manquaient pour la dernière facture. On peut supprimer ces tests si ce n'est qu'une erreur de copier-coller qui ne se reproduira plus, ou, comme l'a fait Job75, faire une correction des données d'entrée.

Le TS permet de faire rapidement un TCD (voir feuille "Infos Factures") pour obtenir une récapitulation par N° de facture par exemple.

Comme le fait @job75 la macro est lancée par l'événement Worksheet_Activate de la feuille "Résultat"
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
escudo à dit:
Les données sources sont au format PDF et, lorsqu'elles sont converties en Excel, un décalage apparaît.
Cliquez pour agrandir...
Salut,
qu'est-ce qui est utilisé pour extraire les données PDF vers Excel ? C'est cela qui peut introduire des décalages entre les différentes colonnes. Il y a peut-être possibilité d'extraire directement les données utiles des PDF vers un tableau Excel avec PowerQuery par exemple.

Nullosse.
 
Vote positif 0 Vote négatif
Bonjour le forum,

La macro de mon post #15 s'exécute chez moi en 6,7 millièmes de seconde.

Celle-ci est 2 fois plus rapide, elle s'exécute en 3,2 millièmes de seconde :
VB: 
Sub Extraction()
Dim F As Worksheet, lig&, DL&, tablo, i&, sejour As Range, x$, a(1 To 7), y As Variant, s, ub%, hTVA As Variant, c As Range
Application.ScreenUpdating = False
Set F = Sheets("Résultat")
F.Rows("2:" & Rows.Count).ClearContents 'RAZ
lig = 2 '1ère ligne de destination
With Sheets("FACTURES")
    DL = .Cells(.Rows.Count, 1).End(xlUp).Row 'dernière ligne
    tablo = .Range("A1:A" & DL + 1) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo) - 1
        If UCase(Left(tablo(i, 1), 6)) = "SEJOUR" Then
            Set sejour = .Cells(i, 1)
            x = tablo(i, 1) & "/"
            Erase a 'efface le tableau a
            a(1) = Trim(Mid(x, 9, InStr(x, "/") - 9)) 'nom
            x = "/ CHB"
            y = Application.HLookup("*" & x & "*", sejour.EntireRow, 1, 0)
            If Not IsError(y) Then a(2) = Mid(y, InStr(y, x) + 2) 'chambre
            x = Replace(Replace(UCase(sejour(4)), ".", "/"), "DU", "")
            s = Split(x, "AU"): ub = UBound(s)
            If ub > -1 Then If IsDate(s(0)) Then a(3) = CDate(s(0)) 'date arrivée
            If ub > 0 Then If IsDate(s(1)) Then a(4) = CDate(s(1)) 'date départ
            x = sejour(2)
            a(5) = Trim(Mid(x, InStr(x, ":") + 1)) 'facture n°
            hTVA = Application.Match("*TVA*", sejour(5, 2).Resize(DL - sejour(4).Row), 0) 'pour limiter les recherches
            If IsNumeric(hTVA) Then
                For Each c In sejour(5, 5).Resize(hTVA - 1, 2) 'colonnes E ou F
                    If c < 0 Then
                        a(6) = c
                        a(7) = .Cells(c.Row, 2)
                        F.Cells(lig, 1).Resize(, 7) = a 'restitution
                        lig = lig + 1
                    End If
                Next c
            End If
            If a(6) = "" Then F.Cells(lig, 1).Resize(, 7) = a: lig = lig + 1 'restitution
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "Extraction terminée"
End Sub
Je n'utilise plus la méthode Find qui n'est pas très rapide.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour le forum,

J'ai recopié les 313 lignes de la feuille FACTURES sur 313 000 lignes.

La macro précédente s'exécute bien sûr en 3,2 secondes.

Dans ce fichier (3) la macro s'exécute en 1,9 seconde :
VB: 
Sub Extraction()
Dim DL&, tablo, a(), i&, n&, sejour As Range, x$, y As Variant, s, ub%, hTVA As Variant, c As Range, j%
With Sheets("FACTURES")
    DL = .Cells(.Rows.Count, 1).End(xlUp).Row 'dernière ligne
    tablo = .Range("A1:A" & DL + 1) 'matrice, plus rapide, au moins 2 éléments
    ReDim a(1 To DL, 1 To 7)
    For i = 1 To DL
        If UCase(Left(tablo(i, 1), 6)) = "SEJOUR" Then
            n = n + 1
            Set sejour = .Cells(i, 1)
            x = tablo(i, 1) & "/"
            a(n, 1) = Trim(Mid(x, 9, InStr(x, "/") - 9)) 'nom
            x = "/ CHB"
            y = Application.HLookup("*" & x & "*", sejour.EntireRow, 1, 0)
            If Not IsError(y) Then a(n, 2) = Mid(y, InStr(y, x) + 2) 'chambre
            x = Replace(Replace(UCase(sejour(4)), ".", "/"), "DU", "")
            s = Split(x, "AU"): ub = UBound(s)
            If ub > -1 Then If IsDate(s(0)) Then a(n, 3) = CDate(s(0)) 'date arrivée
            If ub > 0 Then If IsDate(s(1)) Then a(n, 4) = CDate(s(1)) 'date départ
            x = sejour(2)
            a(n, 5) = Trim(Mid(x, InStr(x, ":") + 1)) 'facture n°
            hTVA = Application.Match("*TVA*", sejour(5, 2).Resize(DL - sejour(4).Row), 0) 'pour limiter les recherches
            If IsNumeric(hTVA) Then
                For Each c In sejour(5, 5).Resize(hTVA - 1, 2) 'colonnes E ou F
                    If c < 0 Then
                        If a(n, 6) Then
                            For j = 1 To 5: a(n + 1, j) = a(n, j): Next j 'copie la ligne sur la suivante
                            n = n + 1
                        End If
                        a(n, 6) = c
                        a(n, 7) = .Cells(c.Row, 2)
                    End If
                Next c
            End If
        End If
    Next i
End With
'---restitution---
With Sheets("Résultat").[A2] '1ère cellule de destination
    If n Then .Resize(n, 7) = a
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, 7).ClearContents 'RAZ en dessous
End With
MsgBox "Extraction terminée"
End Sub
Le tableau a est maintenant un tableau à 2 dimensions qui récupère tous les résultats.

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75 à dit:
Bonjour le forum,

J'ai recopié les 313 lignes de la feuille FACTURES sur 313 000 lignes.

La macro précédente s'exécute bien sûr en 3,2 secondes.

Dans ce fichier (3) la macro s'exécute en 1,9 seconde :
VB: 
Sub Extraction()
Dim DL&, tablo, a(), i&, n&, sejour As Range, x$, y As Variant, s, ub%, hTVA As Variant, c As Range, j%
With Sheets("FACTURES")
    DL = .Cells(.Rows.Count, 1).End(xlUp).Row 'dernière ligne
    tablo = .Range("A1:A" & DL + 1) 'matrice, plus rapide, au moins 2 éléments
    ReDim a(1 To DL, 1 To 7)
    For i = 1 To DL
        If UCase(Left(tablo(i, 1), 6)) = "SEJOUR" Then
            n = n + 1
            Set sejour = .Cells(i, 1)
            x = tablo(i, 1) & "/"
            a(n, 1) = Trim(Mid(x, 9, InStr(x, "/") - 9)) 'nom
            x = "/ CHB"
            y = Application.HLookup("*" & x & "*", sejour.EntireRow, 1, 0)
            If Not IsError(y) Then a(n, 2) = Mid(y, InStr(y, x) + 2) 'chambre
            x = Replace(Replace(UCase(sejour(4)), ".", "/"), "DU", "")
            s = Split(x, "AU"): ub = UBound(s)
            If ub > -1 Then If IsDate(s(0)) Then a(n, 3) = CDate(s(0)) 'date arrivée
            If ub > 0 Then If IsDate(s(1)) Then a(n, 4) = CDate(s(1)) 'date départ
            x = sejour(2)
            a(n, 5) = Trim(Mid(x, InStr(x, ":") + 1)) 'facture n°
            hTVA = Application.Match("*TVA*", sejour(5, 2).Resize(DL - sejour(4).Row), 0) 'pour limiter les recherches
            If IsNumeric(hTVA) Then
                For Each c In sejour(5, 5).Resize(hTVA - 1, 2) 'colonnes E ou F
                    If c < 0 Then
                        If a(n, 6) Then
                            For j = 1 To 5: a(n + 1, j) = a(n, j): Next j 'copie la ligne sur la suivante
                            n = n + 1
                        End If
                        a(n, 6) = c
                        a(n, 7) = .Cells(c.Row, 2)
                    End If
                Next c
            End If
        End If
    Next i
End With
'---restitution---
With Sheets("Résultat").[A2] '1ère cellule de destination
    If n Then .Resize(n, 7) = a
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, 7).ClearContents 'RAZ en dessous
End With
MsgBox "Extraction terminée"
End Sub
Le tableau a est maintenant un tableau à 2 dimensions qui récupère tous les résultats.

A+
Cliquez pour agrandir...
Merci Mr Job75, tu es le meilleur ! Ton aide m'a beaucoup permis de progresser dans mon travail. Un grand merci à toi et à tous ceux qui m'ont soutenu sur ce forum.
 
Vote positif 0 Vote négatif
Bonjour escudo, le forum,

Ce n'était pas fini, marquez plutôt ce post comme solution, la macro s'exécute en 1,4 seconde chez moi :
VB: 
Sub Extraction()
Dim DL&, tablo, a(), i&, n&, sejour As Range, x$, y As Variant, s, ub%, hTVA As Variant, b, ii&, jj%, j%
With Sheets("FACTURES")
    DL = .Cells(.Rows.Count, 1).End(xlUp).Row 'dernière ligne
    tablo = .Range("A1:A" & DL + 1) 'matrice, plus rapide, au moins 2 éléments
    ReDim a(1 To DL, 1 To 7)
    For i = 1 To DL
        If UCase(Left(tablo(i, 1), 6)) = "SEJOUR" Then
            n = n + 1
            Set sejour = .Cells(i, 1)
            x = tablo(i, 1) & "/"
            a(n, 1) = Trim(Mid(x, 9, InStr(x, "/") - 9)) 'nom
            x = "/ CHB"
            y = Application.HLookup("*" & x & "*", sejour.EntireRow, 1, 0)
            If Not IsError(y) Then a(n, 2) = Mid(y, InStr(y, x) + 2) 'chambre
            x = Replace(Replace(UCase(sejour(4)), ".", "/"), "DU", "")
            s = Split(x, "AU"): ub = UBound(s)
            If ub > -1 Then If IsDate(s(0)) Then a(n, 3) = CDate(s(0)) 'date arrivée
            If ub > 0 Then If IsDate(s(1)) Then a(n, 4) = CDate(s(1)) 'date départ
            x = sejour(2)
            a(n, 5) = Trim(Mid(x, InStr(x, ":") + 1)) 'facture n°
            hTVA = Application.Match("*TVA*", sejour(5, 2).Resize(DL - sejour(4).Row), 0) 'pour limiter les recherches
            If IsNumeric(hTVA) Then
                b = sejour(5, 2).Resize(hTVA - 1, 5) 'matrice, plus rapide, colonnes B à F
                For ii = 1 To UBound(b)
                    For jj = 4 To 5
                        If b(ii, jj) < 0 Then
                            If a(n, 6) Then
                                For j = 1 To 5: a(n + 1, j) = a(n, j): Next j 'copie la ligne sur la suivante
                                n = n + 1
                            End If
                            a(n, 6) = b(ii, jj) 'montant < 0
                            a(n, 7) = b(ii, 1) 'mode de paiement
                        End If
                Next jj, ii
            End If
        End If
    Next i
End With
'---restitution---
With Sheets("Résultat").[A2] '1ère cellule de destination
    If n Then .Resize(n, 7) = a
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, 7).ClearContents 'RAZ en dessous
End With
MsgBox "Extraction terminée"
End Sub
Au lieu de travailler sur une plage de cellules on utilise la matrice b.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Solution
job75 à dit:
Bonjour escudo, le forum,

Ce n'était pas fini, marquez plutôt ce post comme solution, la macro s'exécute en 1,4 seconde chez moi :
VB: 
Sub Extraction()
Dim DL&, tablo, a(), i&, n&, sejour As Range, x$, y As Variant, s, ub%, hTVA As Variant, b, ii&, jj%, j%
With Sheets("FACTURES")
    DL = .Cells(.Rows.Count, 1).End(xlUp).Row 'dernière ligne
    tablo = .Range("A1:A" & DL + 1) 'matrice, plus rapide, au moins 2 éléments
    ReDim a(1 To DL, 1 To 7)
    For i = 1 To DL
        If UCase(Left(tablo(i, 1), 6)) = "SEJOUR" Then
            n = n + 1
            Set sejour = .Cells(i, 1)
            x = tablo(i, 1) & "/"
            a(n, 1) = Trim(Mid(x, 9, InStr(x, "/") - 9)) 'nom
            x = "/ CHB"
            y = Application.HLookup("*" & x & "*", sejour.EntireRow, 1, 0)
            If Not IsError(y) Then a(n, 2) = Mid(y, InStr(y, x) + 2) 'chambre
            x = Replace(Replace(UCase(sejour(4)), ".", "/"), "DU", "")
            s = Split(x, "AU"): ub = UBound(s)
            If ub > -1 Then If IsDate(s(0)) Then a(n, 3) = CDate(s(0)) 'date arrivée
            If ub > 0 Then If IsDate(s(1)) Then a(n, 4) = CDate(s(1)) 'date départ
            x = sejour(2)
            a(n, 5) = Trim(Mid(x, InStr(x, ":") + 1)) 'facture n°
            hTVA = Application.Match("*TVA*", sejour(5, 2).Resize(DL - sejour(4).Row), 0) 'pour limiter les recherches
            If IsNumeric(hTVA) Then
                b = sejour(5, 2).Resize(hTVA - 1, 5) 'matrice, plus rapide, colonnes B à F
                For ii = 1 To UBound(b)
                    For jj = 4 To 5
                        If b(ii, jj) < 0 Then
                            If a(n, 6) Then
                                For j = 1 To 5: a(n + 1, j) = a(n, j): Next j 'copie la ligne sur la suivante
                                n = n + 1
                            End If
                            a(n, 6) = b(ii, jj) 'montant < 0
                            a(n, 7) = b(ii, 1) 'mode de paiement
                        End If
                Next jj, ii
            End If
        End If
    Next i
End With
'---restitution---
With Sheets("Résultat").[A2] '1ère cellule de destination
    If n Then .Resize(n, 7) = a
    .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, 7).ClearContents 'RAZ en dessous
End With
MsgBox "Extraction terminée"
End Sub
Au lieu de travailler sur une plage de cellules on utilise la matrice b.

A+
Cliquez pour agrandir...
Un immense merci, tu es génial ! Ton code est aussi rapide que l'éclair !
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

G
  • Résolu(e)
Microsoft 365 Séparer Numéro de compte et intitulés d'une colonne
Réponses
2
Affichages
123
Germaine
G
D
  • Résolu(e)
XL 2019 Nouveau Numéro
2 3 4
Réponses
57
Affichages
2 K
patricktoulon
patricktoulon
N
  • Résolu(e)
Microsoft 365 Optimisation tableau avec adresse mail et numéro de téléphone (débutant)
Réponses
4
Affichages
154
JHA
J
W
  • Résolu(e)
XL 2016 Placer mes photos dans la colonne A, [A3], [A4],etc, jusqu'en [A99] selon le prénom et le nom colonnes B et C
2
Réponses
26
Affichages
407
Webperegrino
W
T
  • Résolu(e)
XL 2010 VBA - Lister fichiers et décortiquer le nom des fichiers dans colonne A et B
Réponses
5
Affichages
524
sylvanu
sylvanu
C
  • Question Question
Microsoft 365 Ajout de données dans tableau existant
Réponses
9
Affichages
231
chnico80
C
C
  • Résolu(e)
XL 2016 humains VS chatGPT
Réponses
9
Affichages
346
AtTheOne
AtTheOne
R
  • Question Question
XL 2010 Copie de plusieurs plages de cellules spécifiques dans le presse-papier
2
Réponses
20
Affichages
462
Dranreb
Dranreb
M
  • Question Question
Microsoft 365 [RESOLU] Enregistrer avec un nouveau nom sans macro et sans le bouton
Réponses
2
Affichages
162
Marboi
M
B
  • Résolu(e)
XL 2021 Séparer les adresses (Rue et N°) en 2 cellules avec un macro
2
Réponses
20
Affichages
2 K
Banbara
B
Jelose
  • Question Question
Microsoft 365 Modèle de facture avec macro
2
Réponses
18
Affichages
687
Jelose
Jelose
D
  • Résolu(e)
Microsoft 365 Remplissage colonne automatique dépendant d'un tableau
Réponses
7
Affichages
682
fanfan38
fanfan38
luno123
  • Question Question
Microsoft 365 Création automatique de feuille et le remplissage correspondant
Réponses
8
Affichages
231
gbinforme
G
P
  • Résolu(e)
XL 2021 Requête API - VBA Excel - Parse JSON
Réponses
2
Affichages
238
picc
P
N
  • Résolu(e)
Microsoft 365 Regroupement de quantité et longueur VBA ou Power Query
2
Réponses
25
Affichages
775
job75
job75
H
  • Question Question
XL 2013 Saisie sécurisée numéros de téléphone et ajout fonction clic droit de la souris
2
Réponses
21
Affichages
859
Helios77
H
B
  • Résolu(e)
XL 2013 Regrouper des listes de noms et prénoms
Réponses
7
Affichages
627
Birobi
B
P
  • Résolu(e)
XL 2016 VBA Insérer une date dans le nom de fichiers PDF publipostés via WORD à partir d"excel
Réponses
3
Affichages
241
PHIL37
P
D
  • Question Question
XL pour MAC macro vba bibliotheque
Réponses
4
Affichages
292
vgendron
vgendron
M
  • Question Question
Microsoft 365 Comptabilité : Création d'un fichier automatique d'analyse de comptes
Réponses
2
Affichages
681
Max
M
Retour