Copy Folder, sub-Folder & contain of files From VB6

Option Explicit
Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
    Dim j As Long
    Dim MyFile As String
    Dim strSource As String
    Dim strDest As String
    strSource = "S:\ACC\ACC Common share\New\Original Data from System\CIC Original"
    strDest = "S:\ACC\ACC Common share\New\ACC-Report in Vietnam\CIC\Monthly_Credit Infor\CIC Report"
    ReDim Arr(0)
    Counter = 0
    Arr(0) = strSource
    Arr = GetSubFolders(strSource)
    'Application.ScreenUpdating = False
    'Application.DisplayAlerts = False

    For j = LBound(Arr) To UBound(Arr)
        Call XcopyFiles(Arr(j) & "\CREDIT_INFO_*.XLS", strDest)
    Next j
End Sub

Function GetSubFolders(RootPath As String)
    Dim fso As Object
    Dim fld As Object
    Dim sf As Object
    Dim myArr
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(RootPath)
    For Each sf In fld.subfolders
        Counter = Counter + 1
        ReDim Preserve Arr(Counter)
        Arr(Counter) = sf.Path
        myArr = GetSubFolders(sf.Path)
    Next
    GetSubFolders = Arr
    Set sf = Nothing: Set fld = Nothing: Set fso = Nothing
End Function

Sub XcopyFiles(strSource, strDestination)
Dim wsh As Object
    Set wsh = CreateObject("wscript.shell")
    wsh.Run "xcopy.exe """ & strSource & """ """ & strDestination & """ /y /r", 1, True
    'Application.ScreenUpdating = False
    'Application.DisplayAlerts = False
    Set wsh = Nothing
End Sub