Need To open and Save a folder location selected by user

I have the below code set that I need help modifying. What I am trying to do:

1) Have the hard coded folder path be chosen by a user and then saved so that it can be used later in the code (Sub Rename Files)
2) Have that folder path be the selected location for Sub Rename Files so that the user does not have to reselect the folder that they chose originally (step 1)

Please let me know if there are any questions.

Public Sub AddOlEObject()

 Dim mainWorkBook As Workbook
 
    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate
    FolderPath = "C:\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "tif", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = counter + 1
                  Sheets("Sheet1").Range("A" & counter + 1).Value = fls.Name
                  Sheets("Sheet1").Range("B" & counter + 1).ColumnWidth = 110
                Sheets("Sheet1").Range("B" & counter + 1).RowHeight = 150
                Sheets("Sheet1").Range("B" & counter + 1).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Sheet1").Activate
            End If
        End If
    Next
End Sub



Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 100
            .Height = 130
        End With
        .Left = ActiveSheet.Range("B" & counter + 1).Left
        .Top = ActiveSheet.Range("B" & counter + 1).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Sub RenameFiles()
'Updateby20141124
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
If .Show = -1 Then
    xDir = .SelectedItems(1)
    xFile = Dir(xDir & Application.PathSeparator & "*")
    Do Until xFile = ""
        xRow = 0
        On Error Resume Next
        xRow = Application.Match(xFile, Range("A:A"), 0)
        If xRow > 0 Then
            Name xDir & Application.PathSeparator & xFile As _
            xDir & Application.PathSeparator & Cells(xRow, "H").Value
        End If
        xFile = Dir
    Loop
End If
End With
End Sub

Moderator's note: Please take the time to review our rules. There aren't many, and they are all important. Rule #3 requires code tags. I have added them for you this time because you are a new member. --6StringJazzer