Code

Sub CopyWorkbooks()

  Dim ZipFolder As String

  Dim DestFolder As String

  Dim fileName As String

  Dim fileNumber As String

  Dim subFolder As String

  ' Get the ZipFolder and DestFolder from the "Input" worksheet

  With ThisWorkbook.Sheets("Input")

    ZipFolder = .Range("ZipFolder").Value

    DestFolder = .Range("DestFolder").Value

  End With

  ' Check if the folders exist

  If Dir(ZipFolder, vbDirectory) = "" Then

    MsgBox "ZipFolder does not exist"

    Exit Sub

  End If

  If Dir(DestFolder, vbDirectory) = "" Then

    MsgBox "DestFolder does not exist"

    Exit Sub

  End If

  ' Loop through all files in the ZipFolder

  fileName = Dir(ZipFolder & "\*.xls")

  Do While fileName <> ""

    ' Get the file number from the file name

    fileNumber = Left(fileName, InStr(fileName, " ") - 1)

    ' Create the subfolder path

    subFolder = DestFolder & "\" & fileNumber

    ' Create the subfolder if it doesn't exist

    If Dir(subFolder, vbDirectory) = "" Then

      MkDir subFolder

    End If

    ' Copy the file to the subfolder

    FileCopy ZipFolder & "\" & fileName, subFolder & "\" & fileName

    ' Get the next file name

    fileName = Dir()

  Loop

End Sub