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

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 !

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
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 =...
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
 
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:
Les données sources sont au format PDF et, lorsqu'elles sont converties en Excel, un décalage apparaît.
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.
 
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

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:
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+
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.
 
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

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+
Un immense merci, tu es génial ! Ton code est aussi rapide que l'éclair !
 
- 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

Réponses
18
Affichages
687
Réponses
4
Affichages
291
Retour