Power Query Manipulation des cellules nommées

Sub Create_Named_Ranges_List()

Dim rnOmrade As Range
Dim nNamn As Name
Dim lnNamn As Long, lnAntal As Long
Dim Y As Range

'************************************
' first verif is there are active names
'************************************
lnAntal = 0
For Each nNamn In ActiveWorkbook.Names
     lnAntal = lnAntal + 1
Next nNamn
If lnAntal = 0 Then
   MsgBox "Could not find any names", vbInformation, "Create Namelist"
   Exit Sub
End If


Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Namelist").Delete
ActiveWorkbook.Sheets.Add

On Error GoTo 0

'********************************
'       set columns names       *
'********************************
With ActiveSheet
       .Name = "Namelist"
       .Cells(1, 1).Value = "Name:"
       .Cells(1, 2).Value = "Value:"
       .Cells(1, 3).Value = "Refer to:"
       .Cells(1, 4).Value = "cell1:"
       .Cells(1, 5).Value = "cell2:"
       .Cells(1, 6).Value = "Start:"
       .Cells(1, 7).Value = "End:"
       With .Range("A1:G1")
              .Font.Bold = True
              .Font.ColorIndex = 10
              .Font.Size = 10
       End With
End With


lnNamn = 2
For Each nNamn In ActiveWorkbook.Names
       If nNamn.Name Like "*!Print_*" Then GoTo Fortsatt
       ActiveSheet.Cells(lnNamn, 1).Value = nNamn.Name
       ActiveSheet.Hyperlinks.Add _
                                Anchor:=ActiveSheet.Cells(lnNamn, 1), _
                                Address:="", _
                                SubAddress:=nNamn.Name
       ActiveSheet.Cells(lnNamn, 3).Value = "'" & nNamn.RefersTo
       ActiveSheet.Cells(lnNamn, 3).InsertIndent 1
       On Error Resume Next
       Set rnOmrade = nNamn.RefersToRange
       If rnOmrade.Cells.Count > 1 Then
              ActiveSheet.Cells(lnNamn, 2).Value = "Nothing"
       Else
              With ActiveSheet.Cells(lnNamn, 2)
                   .Value = nNamn.Value
                   .NumberFormat = rnOmrade.NumberFormat
              End With
       End If
       ActiveSheet.Cells(lnNamn, 4) = nNamn.RefersToRange.Address(False, False)
       ActiveSheet.Cells(lnNamn, 6).FormulaR1C1 = "=IFERROR(MID(RC[-2],2,15)/1,IFERROR(MID(rc[-2],3,15)/1,""column""))"
       ActiveSheet.Cells(lnNamn, 7).FormulaR1C1 = "=IFERROR(MID(RC[-2],2,15)/1,IFERROR(MID(rc[-2],3,15)/1,""""))"
'       ActiveSheet.Cells(lnNamn, 8).FormulaR1C1 = "=IFERROR(MID(RC[-2],2,15)/1,IFERROR(MID(rc[-2],3,15)/1,""column""))"
    
       On Error GoTo 0

       lnNamn = lnNamn + 1
Fortsatt:
Next nNamn

Set Y = ActiveSheet.Range("D2:D" & ActiveSheet.Range("D65536").End(xlUp).Row)
Y.TextToColumns Destination:=ActiveSheet.Range("D2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1))

Columns("A:C").EntireColumn.AutoFit
Columns("B").HorizontalAlignment = xlCenter
With Application
       .Calculation = xlCalculationAutomatic
       .ScreenUpdating = True
End With
'instruction eventuelle pour deleter un named range:
'nNamn.delete

End Sub  'Create_Named_Ranges_List

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classseur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim BO As FileDialog 'déclare la variable BO (Boîte Ouvrir)
Dim CS As Workbook 'déclare la variable CS (Classseur Source)
Dim OT As Worksheet 'déclare la variable OL (Onglet Temporaire)
Dim DL As Integer 'déclare la variable Dl (Dernière Ligne)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NC As Byte 'déclare la variable NC (Nombre de Crochets)
Dim LN As Variant 'déclare la variable LN (Liste des Noms)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("Feuil2") 'définit l'onglet destination CD
OD.Range("A1").CurrentRegion.ClearContents 'efface les anciennes valeurs
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
OD.Range("Tableau1").Delete 'supprime le tableau structuré "Tableau1" (génère une erreur s'il n'existe pas)
On Error GoTo 0 'annule la gestion des derreurs
Set BO = Application.FileDialog(msoFileDialogFilePicker) 'définit la boîte d'ouverture BO
With BO 'prend en compte BO
    .AllowMultiSelect = False 'n'autorise la sélection que d'un seul fichier
    .Show 'affiche
    'si un élément sélectionné, ouvre le classeur sélectionné
    If BO.SelectedItems.Count > 0 Then Application.Workbooks.Open (BO.SelectedItems(1))
    Set CS = ActiveWorkbook 'définit la classeur source
    CS.Sheets.Add Before:=CS.Sheets(1) 'ajoute un onglet vierge ne premiere position
    Set OT = ActiveSheet 'définitl'onglet temporaire PT
    OT.Cells(1, 1).ListNames 'copie dans A1 de l'onglet OT la liste des noms du classeur source
End With 'fin de la prise en compte de BO
OD.Activate 'active l'onglet OD
OD.Range("A1").Value = BO.SelectedItems(1) 'écrit le nom du casseur source dans A1
OD.Range("A2").Value = "Nom" 'écrit "Nom" dans A2
OD.Range("B2").Value = "Adresse" 'écrit "Adresse" dans B2
OT.Cells(1, 1).CurrentRegion.Copy OD.Range("A3") 'copie la liste des nom de l'ongelt temporaire OT dans A3 de l'onglet OD
DL = OD.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OD
OD.Columns("A:B").AutoFit 'ajustement des colonnes A et B
OD.ListObjects.Add(xlSrcRange, Range("A2:B" & DL), , xlYes).Name = "Tableau1" 'Transformation de la plage en tableau structuré nommé "Tableau1"
CS.Close False 'ferme le fichier source sans enregistrer (l'onglet temporaire disparaît...)
MsgBox "Liste des noms récupérée !" 'message
End Sub