List files in 4 specific folder

[Access Beginner]

Hello,

I have found code which will list files in a specific folder. Code attached.

I have 4 folders I want files listed in. At the moment I have repeated the code and change the location in the code. I was hoping someone could look at the following code and amend so it'll fit into one piece of code. The location of the list will remain as per the code. Location of folders and where list of files to be placed as below.

Folder 1
Location "R:\Test\Location\Data Request Documents\Debts\RegionalReports"
List Files on sheet "DataDebt" from cell H31

Folder 2
Location "R:\Test\Location\Data Request Documents\Populations\RegionalReports"
List Files on sheet "DataRequestPt" from cell H31

Folder 3
Location "R:\Test\Location\Data Request Documents\Accounts\ZoneReports"
List Files on sheet "Accounts" from cell H31

Folder 4
Location "R:\Test\Location\Data Request Documents\Participation\RegionalReports"
List Files on sheet "PartiData" from cell H31

Sub ListDebtFiles()
Application.ScreenUpdating = False
Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
Dim LastRow As Long
Dim sFilePath As String, Path As String
Dim ar() As Variant
Dim i As Integer, kounter As Integer
Set oFSO = CreateObject("scripting.filesystemobject")
i = 1
kounter = 0
ChDrive "R:\"
ChDir "R:\Test\Location\Data Request Documents\Debts\RegionalReports\"
''''Select folder that contains files
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .InitialFileName = "R:\Test\Location\Data Request Documents\Debts\RegionalReports\"
  .Title = "Please select a folder..."
  If .Show = 0 Then Exit Sub
  sFilePath = .SelectedItems(1) & "\"
End With
Sheets("DataDebt").Range("H31:H" & Sheets("DataDebt").Cells(Rows.Count, "H").End(xlUp).Row).ClearContents
Set oFSOFolder = oFSO.GetFolder(sFilePath)
kounter = oFSOFolder.Files.Count
If kounter > 0 Then
    ReDim ar(1 To kounter, 1 To 1)
Else
MsgBox "Sorry, no files in the selected folder."
    Exit Sub
End If
For Each oFSOFile In oFSOFolder.Files
    ar(i, 1) = oFSOFile.Path
    i = i + 1
Next oFSOFile
Sheets("DataDebt").Range("H31:H" & 31 + kounter - 1).Value = ar()
    
Set oFSOFile = Nothing
Set oFSOFolder = Nothing
Set oFSO = Nothing
Erase ar
ActiveSheet.Columns("H").AutoFit
Application.ScreenUpdating = True
MsgBox "There are " & kounter & " files. Debt reports have been created"
End Sub

Sub ListPopFiles()
Application.ScreenUpdating = False
Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
Dim LastRow As Long
Dim sFilePath As String, Path As String
Dim ar() As Variant
Dim i As Integer, kounter As Integer
Set oFSO = CreateObject("scripting.filesystemobject")
i = 1
kounter = 0
ChDrive "R:\"
ChDir "R:\Test\Location\Data Request Documents\Populations\RegionalReports\"
''''Select folder that contains files
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .InitialFileName = "R:\Test\Location\Data Request Documents\Populations\RegionalReports\"
  .Title = "Please select a folder..."
  If .Show = 0 Then Exit Sub
  sFilePath = .SelectedItems(1) & "\"
End With
Sheets("DataRequestPt").Range("H31:H" & Sheets("DataRequestPt").Cells(Rows.Count, "H").End(xlUp).Row).ClearContents
Set oFSOFolder = oFSO.GetFolder(sFilePath)
kounter = oFSOFolder.Files.Count
If kounter > 0 Then
    ReDim ar(1 To kounter, 1 To 1)
Else
MsgBox "Sorry, no files in the selected folder."
    Exit Sub
End If
For Each oFSOFile In oFSOFolder.Files
    ar(i, 1) = oFSOFile.Path
    i = i + 1
Next oFSOFile
Sheets("DataRequestPt").Range("H31:H" & 31 + kounter - 1).Value = ar()
    
Set oFSOFile = Nothing
Set oFSOFolder = Nothing
Set oFSO = Nothing
Erase ar
ActiveSheet.Columns("H").AutoFit
Application.ScreenUpdating = True
MsgBox "There are " & kounter & " files. Oopulation reports have been created"
End Sub
 
 
Sub ListAccountsFiles()
Application.ScreenUpdating = False
Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
Dim LastRow As Long
Dim sFilePath As String, Path As String
Dim ar() As Variant
Dim i As Integer, kounter As Integer
Set oFSO = CreateObject("scripting.filesystemobject")
i = 1
kounter = 0
ChDrive "R:\"
ChDir "R:\Test\Location\Data Request Documents\Accounts\ZoneReports\"
''''Select folder that contains files
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .InitialFileName = "R:\Test\Location\Data Request Documents\Accounts\ZoneReports\"
  .Title = "Please select a folder..."
  If .Show = 0 Then Exit Sub
  sFilePath = .SelectedItems(1) & "\"
End With
Sheets("Accounts").Range("H31:H" & Sheets("Accounts").Cells(Rows.Count, "H").End(xlUp).Row).ClearContents
Set oFSOFolder = oFSO.GetFolder(sFilePath)
kounter = oFSOFolder.Files.Count
If kounter > 0 Then
    ReDim ar(1 To kounter, 1 To 1)
Else
MsgBox "Sorry, no files in the selected folder."
    Exit Sub
End If
For Each oFSOFile In oFSOFolder.Files
    ar(i, 1) = oFSOFile.Path
    i = i + 1
Next oFSOFile
Sheets("Accounts").Range("H31:H" & 31 + kounter - 1).Value = ar()
    
Set oFSOFile = Nothing
Set oFSOFolder = Nothing
Set oFSO = Nothing
Erase ar
ActiveSheet.Columns("H").AutoFit
Application.ScreenUpdating = True
MsgBox "There are " & kounter & " files. Oopulation reports have been created"
End Sub
Sub ListPartiFiles()
Application.ScreenUpdating = False
Dim oFSO As Object, oFSOFolder As Object, oFSOFile As Object
Dim LastRow As Long
Dim sFilePath As String, Path As String
Dim ar() As Variant
Dim i As Integer, kounter As Integer
Set oFSO = CreateObject("scripting.filesystemobject")
i = 1
kounter = 0
ChDrive "R:\"
ChDir "R:\Test\Location\Data Request Documents\Participation\RegionalReports\"
''''Select folder that contains files
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .InitialFileName = "R:\Test\Location\Data Request Documents\Participation\RegionalReports\"
  .Title = "Please select a folder..."
  If .Show = 0 Then Exit Sub
  sFilePath = .SelectedItems(1) & "\"
End With
Sheets("PartiData").Range("H31:H" & Sheets("PartiData").Cells(Rows.Count, "H").End(xlUp).Row).ClearContents
Set oFSOFolder = oFSO.GetFolder(sFilePath)
kounter = oFSOFolder.Files.Count
If kounter > 0 Then
    ReDim ar(1 To kounter, 1 To 1)
Else
MsgBox "Sorry, no files in the selected folder."
    Exit Sub
End If
For Each oFSOFile In oFSOFolder.Files
    ar(i, 1) = oFSOFile.Path
    i = i + 1
Next oFSOFile
Sheets("PartiData").Range("H31:H" & 31 + kounter - 1).Value = ar()
    
Set oFSOFile = Nothing
Set oFSOFolder = Nothing
Set oFSO = Nothing
Erase ar
ActiveSheet.Columns("H").AutoFit
Application.ScreenUpdating = True
MsgBox "There are " & kounter & " files. Population reports have been created"
End Sub