Insérer une partie du nom d'un fichier lors d'import XML

Le 27/09/2022 à 16:50

Bonjour à tous,

J'ai une première partie de code qui sert à importer dans une nouvelle feuille tous les fichiers XML d'un dossier. Cela marche super. Seulement j'aimerais pouvoir en plus rajouter en colonne A les deux derniers caractères du nom du fichier, et ce pour chaque fichier.

Par exemple, chaque ligne provenant du fichier xxx_31.xlm aurait en colonne A la valeur 31

Je vous joint un exemple de ce que j'aimerais obtenir, et mon code ci-dessous.

Merci !

17exemple.xlsx (16.11 Ko)
Sub ImportXML()

    Sheets.Add(Before:=Sheets(1)).Name = "Export"

    Dim xWb As Workbook
    Dim xSWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xCount As Long
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Application.ScreenUpdating = False
    Set xSWb = ThisWorkbook
    xCount = 1
    xFile = Dir(xStrPath & "\*.xml")
    Do While xFile <> ""
        Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
        xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
        xWb.Close False
        xCount = xSWb.Sheets(1).UsedRange.Rows.Count + 2
        xFile = Dir()
    Loop
    Application.ScreenUpdating = True
    xSWb.Save
    Exit Sub
ErrHandler:
    MsgBox "no files xml"
End Sub
Le 27/09/2022 à 18:27

Bonjour,

Sans filet (aucun...)

Sub ImportXML()

    Sheets.Add(Before:=Sheets(1)).Name = "Export"

    Dim xWb As Workbook
    Dim xSWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xCount As Long
    Dim Num_Fich As Object
    Set Num_Fich = CreateObject("vbscript.regexp")
    Dim AA As Object
    Num_Fich.pattern = "[\d]+"
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Application.ScreenUpdating = False
    Set xSWb = ThisWorkbook
    xCount = 1
    xFile = Dir(xStrPath & "\*.xml")
    Do While xFile <> ""
        Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
        xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
        Set AA = Num_Fich.Execute(xWb.Name)
        xWb.Close False
        If AA.Count > 0 Then xSWb.Sheets(1).Cells(xCount, 1).Resize(Selection.Rows.Count).Value = CInt(AA(0))
        xCount = xSWb.Sheets(1).UsedRange.Rows.Count + 2
        xFile = Dir()
    Loop
    Application.ScreenUpdating = True
    xSWb.Save
    Exit Sub
ErrHandler:
    MsgBox "no files xml"
End Sub

J'utilise l'objet RegExp qui permet (entre autres) d'isoler les caractères numériques dans une chaîne de caractères.

Ceci sera valable si le nom du fichier xml ne comporte pas d'autres caractères numériques.

Sans test...

Bonne soirée

Le 28/09/2022 à 09:22

Bonjour Cousinhub,

Merci pour ta proposition.

Malheureusement j'ai d'autres caractères numériques dans les noms de mes fichiers et j'ai l'impression que dans ton programme, le nom ne s'ajoute pas dans chaque ligne mais uniquement sur la première. Un grand merci quand même d'avoir réfléchi à mon sujet.

Madben

Le 28/09/2022 à 09:30

Bonjour,

Pour les noms de tes fichiers, est-ce qu'ils respectent toujours :

********_000.xls* (i-e : les chiffres à obtenir entre le dernier "underscore" et le point)?

2 ème question, en déroulant le code proposé en mode pas-à-pas, une fois le fichier d'export fermé :

xWb.Close False

Est-ce que la zone que tu viens de copier est toujours sélectionnée dans ton fichier d'import (ThisWorkbook, xSWB)? (d'où le Selection.Rows.Count dans mon code)

@ te relire

Le 28/09/2022 à 10:01

Re,

Merci pour ta réponse. Jusqu'à présent les noms de fichiers étaient sous la forme ***_xx00.xml, entre le dernier underscore et le point se situent les chiffres qui m'intéressent, il n'y a pas d'autres chiffres entre le dernier underscore et le point qu'il ne faudrait pas prendre en compte.

2 ème question, en déroulant le code proposé en mode pas-à-pas, une fois le fichier d'export fermé :

xWb.Close False

Est-ce que la zone que tu viens de copier est toujours sélectionnée dans ton fichier d'import (ThisWorkbook, xSWB)? (d'où le Selection.Rows.Count dans mon code)

En exécutant pas à pas, j'ai l'impression que dans ma feuille nouvellement créée la plage copiée n'est plus active, c'est la cellule A1 qui est active.

En revanche, je ne peux te répondre pour le fichier d'import car il ne s'ouvre pas explicitement lorsque j'exécute la macro.

J'espère avoir été clair,

En attendant de te lire !

Le 28/09/2022 à 10:07

Bonjour à tous !

Si VBA n'est pas un horizon indépassable, je vous livre une proposition via Power Query (nativement intégré à votre version Excel) :

13madben-pq-elements-dossier-v0.xlsx (27.62 Ko)

EDIT : Mettre à jour le chemin du dossier à analyser puis "Actualiser tout".

Le 28/09/2022 à 10:13

Bonjour JFL,

Merci pour votre proposition. Néanmoins j'ai aussi besoin d'insérer le contenu des fichiers XML, et pas uniquement les deux derniers caractères des fichiers.

Cdlt

Le 28/09/2022 à 10:20

Re-,

J'ai adapté le code, en maintenant le RegExp (au vu du nom, qui semble-t-il, comporte des lettres et des chiffres entre le dernier underscore et le point)

Et en supposant que la colonne B est bien remplie lors de l'import

Sub ImportXML()
Sheets.Add(Before:=Sheets(1)).Name = "Export"
Dim xWb As Workbook, xSWb As Workbook
Dim xStrPath As String, xFile As String, xFile_Part As String
Dim xFileDialog As FileDialog
Dim xCount As Long
Dim Num_Fich As Object, AA As Object
Dim Le_Deb As Byte, La_Fin As Byte
Set Num_Fich = CreateObject("vbscript.regexp")
Num_Fich.Pattern = "[\d]+"
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
    xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Application.ScreenUpdating = False
Set xSWb = ThisWorkbook
xCount = 1
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
    Le_Deb = InStrRev(xWb.Name, "_") + 1: La_Fin = InStrRev(xWb.Name, ".")
    xFile_Part = Mid(xWb.Name, La_Fin - Le_Deb)
    Set AA = Num_Fich.Execute(xFile_Part)
    xWb.Close False
    With xSWb.Sheets(1)
        If AA.Count > 0 Then .Cells(xCount, 1).Resize(.Cells(Rows.Count, "B").End(xlUp).Row + 1 - xCount).Value = CInt(AA(0))
        xCount = .UsedRange.Rows.Count + 2
    End With
    xFile = Dir()
Loop
Application.ScreenUpdating = True
xSWb.Save
Exit Sub
ErrHandler:
    MsgBox "no files xml"
End Sub

Peut-être?

Le 28/09/2022 à 10:50

Re !

On avance bien, merci cousinhub. L'exécution permet bien d'affecter à la colonne A une valeur pour chaque ligne !

Par contre, cette valeur est 0 à chaque fois, et pas les deux chiffres de fin du nom du fichier.

Je vais essayer de regarder comment tu as paramétrer RegExp, je te tiens au courant si j'y arrive.

EDIT : J'ai activé vbscript.dll dans les Références, ça n'a rien changé.

Le 28/09/2022 à 10:54

Bonjour de nouveau à tous !

Madben a écrit :

Néanmoins j'ai aussi besoin d'insérer le contenu des fichiers XML, et pas uniquement les deux derniers caractères des fichiers.

La structure des fichiers XML à traiter est-elle identique ? Si oui, pouvez-vous poster deux ou trois fichiers anonymisés ?

Le 28/09/2022 à 11:02

Re-,

J'ai fait une erreur dans la définition d'xFile_Part...

Remplace par :

xFile_Part = Mid(xWb.Name, Le_Deb, La_Fin - Le_Deb)

et pour essayer, enlève le CInt, et tu mets juste AA(0):

If AA.Count > 0 Then .Cells(xCount, 1).Resize(.Cells(Rows.Count, "B").End(xlUp).Row + 1 - xCount).Value = AA(0)

Peut-être?

Maintenant, si le nombre est toujours composé de 2 chiffres, tu peux modifier ainsi :

Sub ImportXML()
Sheets.Add(Before:=Sheets(1)).Name = "Export"
Dim xWb As Workbook, xSWb As Workbook
Dim xStrPath As String, xFile As String, xFile_Part As String
Dim xFileDialog As FileDialog
Dim xCount As Long
Dim La_Fin As Byte
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
    xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Application.ScreenUpdating = False
Set xSWb = ThisWorkbook
xCount = 1
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
    La_Fin = InStrRev(xWb.Name, ".")
    xFile_Part = Mid(xWb.Name, La_Fin - 2, 2)
    xWb.Close False
    With xSWb.Sheets(1)
        .Cells(xCount, 1).Resize(.Cells(Rows.Count, "B").End(xlUp).Row + 1 - xCount).Value = xFile_Part
        xCount = .UsedRange.Rows.Count + 2
    End With
    xFile = Dir()
Loop
Application.ScreenUpdating = True
xSWb.Save
Exit Sub
ErrHandler:
    MsgBox "no files xml"
End Sub

On va y arriver...

Le 28/09/2022 à 11:02

Arrêtez tout, on a trouvé la solution ;)

Un énorme MERCI cousinhub pour ton implication, je ne sais même pas comment te remercier !

Merci beaucoup à JFL aussi !

La macro fonctionne exactement comme je le souhaitais, je vais l'adapter pour quelques détails !

Le 28/09/2022 à 11:20

Bonjour à tous de nouveau !

Alors... c'est parfait.

Je vous remercie de ce retour.

Rechercher des sujets similaires à "inserer partie nom fichier lors import xml"