En este caso lo mejor sería crear una función a la que le pasas los parámetros:

**Función:**

    Function copiarPorExtension(sFolderOrigen, sFolderDestino, sExtension)
       For Each sFile In oFSO.GetFolder(sFolderOrigen).Files
          If LCase(oFSO.GetExtensionName(sFile)) = sExtension Then
             If Not oFSO.FileExists(sFolderDestino & "\" &  oFSO.GetFileName(sFile)) Then
               oFSO.GetFile(sFile).Copy sFolderDestino & "\" & oFSO.GetFileName(sFile),True
             End If  
          End If
       Next
    End Function

**Preparar los parámetros y llamar la función desde cualquier parte**

    Dim sOrigen, sDestino, sExtension, dtmValue, sFecha, sHora
    sOrigen = "C:\rutaA\"  
    
    'Para obtener la fecha
    'Almacenaré la fecha en la variable sFecha y la hora en la variable sHora
    'En el ejemplo se crea el nombre de carpeta con la fecha, si quieres que tenga la hora le agregas la variable sHora 
    
    dtmValue = Now()
    
    sFecha = Year(dtmValue)"_" & Month(dtmValue) & "_" & Day(dtmValue) 
    sHora = strDate & "\" & Hour(dtmValue) & "-" & Minute(dtmValue) & "-" & Second(dtmValue)
    sDestino = "C:\ruta_final" & sFecha
    sExtension = "html"

    'Llamamos la función pasándole los parámetros

    Call copiarPorExtension(sOrigen, sDestino, sExtension)

La ventaja de la función es que, en el caso de querer pasar otros parámetros, como trabajar con archivos de extensión txt, doc u otros o con directorios distintos, no necesitas cambiar todo el código, sino solamente los parámetros que pasas a la función.


**Si son varios directorios de origen**
Se crea un array con los nombres de los directorios y se pasa como parámetro.
Nótese que la función `copiarPorExtension ()` quedaría modificada, ya que recibirá como primer parámetro un array, en lugar de una cadena, por eso el primer parámetro se llama ahora `arrOrigenes()` donde las () indican que se trata de un array.

Luego, tendrá otro bucle for donde irá leyendo las diferentes carpetas de origen que recibió en parámetro, donde `arrOrigenes(i)`irá tomando la ruta de los folders existentes en el array (LaRutadelFolder1, LaRutadelFolder2, etc).

Nota: Aquí solo modifico el valor de `arrFoldersOrigen`, los demás valores se declararían tal y como aparece más arriba.

    Dim arrFoldersOrigen
    arrFoldersOrigen = Array ("LaRutadelFolder1","LaRutadelFolder2","LaRutadelFolder3")
    i=0

Para llamar la función:

`Call copiarPorExtension`**`(arrFoldersOrigen,`**` sDestino, sExtension)`

<hr>

    Function copiarPorExtension(arrOrigenes(), sFolderDestino, sExtension)
       For i=0 to ubound(arrOrigenes)
          For Each sFile In oFSO.GetFolder(arrOrigenes(i)).Files
             If LCase(oFSO.GetExtensionName(sFile)) = sExtension Then
                If Not oFSO.FileExists(sFolderDestino & "\" &  oFSO.GetFileName(sFile)) Then
                   oFSO.GetFile(sFile).Copy sFolderDestino & "\" & oFSO.GetFileName(sFile),True
                End If  
             End If
           Next
       Next
    End Function


*Como detalle y aclaración:*
Lo mismo se podría hacer si se desea pasar varias extensiones, se crea un array de extensiones y se le pasa a la función. Entonces habría que crear otro bucle for dentro de cada folder para que busque las extensiones pasadas en el array.