VBA Создать папку с именем файла и переместить по списку

[jungo]

Привет Всем!

Рад снова обратиться к вам за помощью...

Задача:
Исходная позиция: Столбец A, B
Желаемая позиция: Столбец C

Для файлов в папке нужно создать папку по заданному названию (столбец H) и переместить туда файлы заданные в столбце B

*** В столбце H названия могут повторяться
*** Имена файлов не обязательно равны имени новой папки

Заранее огромное спасибо за помощь!

[Aleksandr H.]

тоесть в папке C:\Users\Alexg\Desktop\VBA\ALEX надо создать 21 подпапку с именами из столбца Н. И в каждую из подпапок скопировать 21 файл с именами столбца В из папки C:\Users\Alexg\Desktop\VBA итого надо создать 441 файл и 21 папку?

[jungo]

Сообщение от Aleksandr H.

тоесть в папке C:\Users\Alexg\Desktop\VBA\ALEX надо создать 21 подпапку с именами из столбца Н. И в каждую из подпапок скопировать 21 файл с именами столбца В из папки C:\Users\Alexg\Desktop\VBA итого надо создать 441 файл и 21 папку?

Привет,

Нужно создать 21 подпапку с именами из столбца Н.
Файлы из папки C:\Users\Alexg\Desktop\VBA перенести по заданным подпапкам (которые мы только что создали) строго по столбцу C (то-есть каждый файл в столбце B в подпапку в столбце C).

[Aleksandr H.]

Так с чем помочь-то или надо все сделать вместо Вас?


1. Создание папки: https://best-excel-tutorial.com/57-v...r-in-excel-vba
2. Копирование файлов: https://www.rondebruin.nl/win/s3/win026.htm
комбинируйте.

[jungo]

Сообщение от Aleksandr H.

Так с чем помочь-то или надо все сделать вместо Вас?


1. Создание папки: https://best-excel-tutorial.com/57-v...r-in-excel-vba
2. Копирование файлов: https://www.rondebruin.nl/win/s3/win026.htm
комбинируйте.

Я действительно просмотрел весь и-нет. Почти добрался до цели, но мне не хватает опыта поправить макрос. Петому хоть и редковато тут, но знаю что легче с нуля чем копаться в чужом.

Сообщение от Aleksandr H.

2. Копирование файлов: https://www.rondebruin.nl/win/s3/win026.htm

Мне нужно, что бы новый пач был динамичным - столбец C (подпапки каждый раз разные)
Файлы любых форматов строго по столбцу B

[Aleksandr H.]

Сообщение от jungo

Я действительно просмотрел весь и-нет.

Такое только Чак Норрис умеет.

Option Explicit

Sub DoWork()
    Dim iLastRow As Integer
    Dim i As Integer
    Dim sFolderCopyToPath As String
    Dim sFileCopyFrom As String
    Dim sFileCopyToPath As String
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To iLastRow
        sFolderCopyToPath = Cells(i, "C")
        sFileCopyFrom = Cells(i, "A") & "\" & Cells(i, "B")
        sFileCopyToPath = sFolderCopyToPath & "\" & Cells(i, "B")
        If CreateFolder(sFolderCopyToPath) Then
            sFileCopyToPath = sFileCopyToPath
            FileCopy sFileCopyFrom, sFileCopyToPath
        Else
            MsgBox "Ошибка создания папки из строки " & i
        End If
    Next i
End Sub



Function CreateFolder(ByVal sPath As String) As Boolean

  'create full sPath at once, if required
  'returns False if folder does not exist and could NOT be created, True otherwise
  'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"

    Dim fs As Object
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "\" into 3 "@"
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "\")
    'then set back the @ into \ in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function

[jungo]

Сообщение от Aleksandr H.

Такое только Чак Норрис умеет.

Убил )))))

Огромное спасибо за помощь и юмор.
Буду тестировать.

[jungo]

Сообщение от Aleksandr H.

Такое только Чак Норрис умеет.

Option Explicit

Sub DoWork()
    Dim iLastRow As Integer
    Dim i As Integer
    Dim sFolderCopyToPath As String
    Dim sFileCopyFrom As String
    Dim sFileCopyToPath As String
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To iLastRow
        sFolderCopyToPath = Cells(i, "C")
        sFileCopyFrom = Cells(i, "A") & "\" & Cells(i, "B")
        sFileCopyToPath = sFolderCopyToPath & "\" & Cells(i, "B")
        If CreateFolder(sFolderCopyToPath) Then
            sFileCopyToPath = sFileCopyToPath
            FileCopy sFileCopyFrom, sFileCopyToPath
        Else
            MsgBox "Ошибка создания папки из строки " & i
        End If
    Next i
End Sub



Function CreateFolder(ByVal sPath As String) As Boolean

  'create full sPath at once, if required
  'returns False if folder does not exist and could NOT be created, True otherwise
  'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"

    Dim fs As Object
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "\" into 3 "@"
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "\")
    'then set back the @ into \ in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function

Всё прекрасно работает!!!

Одно "но. . . "
А если в списке есть файл, которого не существует, можно просто пропустить и потом выдать error каких файлов не было?

[Aleksandr H.]

Сообщение от jungo

А если в списке есть файл, которого не существует, можно просто пропустить и потом выдать error каких файлов не было?

it's your hometask