VBA Kopi af celler fra en fil til en anden

Jeg har tidligere spurgt om hjælp her:
https://www.computerworld.dk/eksperten/spm/1028573

Jeg troede det var løst men har opdaget en lille udfordring.

Hvis jeg markere en enkelt adresse på listen som jeg vil oprette en mappe og fil til kommer Fornavn og Efternavn fra øverste række - altså det følger ikke den række som adressen er markeret i.

Link til filen her
https://1drv.ms/x/s!AmNIVonUMzx-6iIIvHX5R833ZVG5?e=Co3L2X



Sub kopi()
Dim intResult As Integer
Dim strPath As String
Dim ws As Worksheet
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Dim sh
Dim UserName As String
UserName = Environ("username")
Set ws = ActiveSheet

'Dialogboks
With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\Users\" & UserName & "\Desktop\"
        .AllowMultiSelect = False
        .Title = _
    "Vælg Bibliotek hvor der skal oprettes Mapper"
        .ButtonName _
    = "Vælg Mappe"
    intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
End With


'check om dialogboks er annulleret
    If intResult <> 0 Then
    strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
 
   
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
 
    For c = 1 To maxCols
 
        r = 1
     
        Do While r <= maxRows
             
          If Len(Dir(strPath & "\" & Rng(r, c), vbDirectory)) = 0 Then
         
                Path = (strPath & "\" & Rng(r, c))
             
                MkDir Path
                ChDir Path
                        Application.ScreenUpdating = False
                                                                                           
                        ThisWorkbook.Sheets("2-Skema").Copy
                        Application.DisplayAlerts = False
                        ActiveWorkbook.SaveAs Filename:="2-Skema v2", FileFormat:=52
                        Application.DisplayAlerts = True
                             
                ' Indsætter adresse i skema
                Worksheets("2-Skema").Cells(9, 2) = (Rng(r, c))
                         
                ' Indsæt navn på skema
                Worksheets("2-Skema").Cells(8, 2) = ws.Cells(r + 3, 3) ' Fornavn
                Worksheets("2-Skema").Cells(7, 2) = ws.Cells(r + 3, 4) ' Efternavn
                     
             
                'Lukning af nyoprettet fil
                If Application.Workbooks.Count = 1 Then
               
                    Application.Quit
         
                Else
           
                  ActiveWorkbook.Close
                     
                End If
                Application.ScreenUpdating = True

' Chdir bib op ellers kan man ikke slette før skabelon ark er lukket.
                ChDir ".."

                On Error Resume Next
     
            End If
           
            r = r + 1
     
        Loop
 
    Next c

End If

End Sub