Sub MDir()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
If Not IsEmpty(oCell) Then MkDir "C:\test\" & oCell
Next
End Sub

'---------------------------------------------------------------------------------------
' File : mDownloadFileFromURL
' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке
'---------------------------------------------------------------------------------------
Option Explicit

'объявление функции API - URLDownloadToFile
' работает на любых ПК под управлением ОС Windows
' на MAC код работать не будет
#If Win64 Then 'для операционных систем с 64-разрядной архитектурой
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
#Else
#If VBA7 Then 'для любых операционных систем с офисом 2010 и выше
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr
#Else 'для 32-разрядных операционных систем
Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
#End If
'переменная для хранения пути к папке

Function CallDownload(sFileURL As String, sFileName As String,sFilePath As String)
' sFileURL - ссылка URL для скачивания файла
' sFileName - имя файла с расширением, которое будет присвоено после скачивания

Dim h
If sFilePath = "" Then
'диалоговое окно выбора папки
'подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then
Exit Function
End If
sFilePath = .SelectedItems(1)
End With
End If

If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
'проверяем есть ли файл с таким же именем в выбранной папке
If Dir(sFilePath & sFileName, 16) = "" Then
'файла нет - скачиваем
h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
Else
'файл есть - запрос на перезапись
If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then
'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно
'отменяем загрузку
If IsBookOpen(sFileName) Then
MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _
vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru"
Else
h = DownloadFileAPI(sFileURL, sFilePath & sFileName)
End If
End If
End If
CallDownload = h
End Function

'функция скачивания файла в выбранную папку
Function DownloadFileAPI(sFileURL, ToPathName)
' sFileURL - ссылка URL для скачивания файла
' ToPathName - полный путь с именем файла для сохранения

Dim h
Dim sFilePath As String
Dim sFileName As String
'вызов функции API для непосредственно скачивания
h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0)
'если h = False - файл не удалось скачать, показываем инф.окно
If h = False Then
MsgBox "Невозможно скачать файл." & vbNewLine & _
"Возможно, у Вас нет прав на создание файлов в выбранной директории." & vbNewLine & _
"Попробуйте выбрать другую папку для сохранения", vbInformation, "www.excel-vba.ru"
Exit Function
Else 'файл успешно скачан
sFileName = Dir(ToPathName, 16)
sFilePath = Replace(ToPathName, sFileName, "")

End If
DownloadFileAPI = h
End Function
'Функция проверки - открыта ли книга с заданным именем
'подробнее:
' http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
Function IsBookOpen(wbName As String) As Boolean
Dim wbBook As Workbook
For Each wbBook In Workbooks
If Windows(wbBook.Name).Visible Then
If wbBook.Name = wbName Then IsBookOpen = True: Exit For
End If
Next wbBook
End Function

=CallDownload(B1;D1&ПРАВСИМВ(B1;5);"C:\test\"&A1&"\")