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

Содержание

Вопрос или проблема
Ответ или решение
Проблема
Решение
Заключение

Вопрос или проблема

Sub WO_SaveUpdate()
Dim WORow As Long, WOCol As Long
Dim AssignedTo As String, SharedFolder As String, FileName As String, FilePath As String
With Sheet1
If .Range(“D4”).Value = Empty Or .Range(“H4”).Value = Empty Or .Range(“D10”).Value = Empty Or .Range(“C15”).Value = Empty Then
MsgBox “Пожалуйста, завершите желтые поля”
Exit Sub
End If
End With

With Sheet3
If .Range(“C4”).Value = Empty Then
MsgBox “Пожалуйста, укажите место для общего доступа”
Exit Sub
End If
End With

With Sheet2
If Worksheets(“WO Data”).Range(“B11”).Value = True Then ‘новый Заказ на работу
WORow = .Range(“C99999”).End(xlUp).Row + 1 ‘Первая доступная строка
Else ‘ Существующий заказ на работу
End If
End With

With Sheet1
For WOCol = 3 To 11
Sheet2.Cells(WORow, WOCol).Value = .Range(.Cells(30, WOCol).Value).Value ‘Записываем значения в строку WO
Sheet4.Range(.Cells(29, WOCol).Value).Value = .Range(.Cells(30, WOCol).Value).Value ‘Записываем значения в шаблон WO
Next WOCol
Sheet2.Range(“B11”).Value = False ‘Устанавливаем новый WO в значение false
Sheet2.Range(“B12”).Value = WORow

‘Создать/обновить заказ на работу в общей папке, если статус открыт
If .Range(“D8”).Value = “Open” Then
AssignedTo = .Range(“H4”).Value ‘Назначено
SharedFolder = Sheet3.Range(“C4”).Value ‘Место общего доступа
FileName = “Заказ на работу_” & .Range(“D6”).Value ‘Имя файла Заказ на работу & #
If Dir(SharedFolder & “” & AssignedTo, vbDirectory) = “” Then MkDir (SharedFolder & “” & AssignedTo) ‘Создать папку, если она не существует
FilePath = SharedFolder & “” & AssignedTo & “” & FileName & “.xlsx”
On Error Resume Next
Kill (FilePath)
On Error GoTo 0
Sheet4.Range(“A1:B26”).Copy
Workbooks.Add
ActiveWorkbook.Sheets(1).Range(“A1”).PasteSpecial xlPasteAll
ActiveWorkbook.Sheets(1).Range(“A1”).PasteSpecial xlPasteColumnWidths
ActiveWorkbook.SaveAs FilePath
ActiveWorkbook.Close False
Sheet2.Range(“G” & WORow).Value = Now ‘Обновить назначение на текущую дату и время
End If

End With
End Sub

Ответ или решение

Чтобы создать папку на рабочем столе с помощью VBA и устранить проблемы, связанные с созданием директории, вам нужно учесть несколько важных аспектов, которые могут вызвать ошибку. Ниже представлен подробный анализ вашего кода и рекомендации по его корректировке.

Проблема

Ваш код написан с использованием метода MkDir для создания папки, используя путь, который определяется переменной SharedFolder, получаемой из ячейки на листе. Если этот путь не является правильным или не имеет необходимых разрешений на создание папки, то MkDir будет выдавать ошибку. Также, важно убедиться, что путь к рабочему столу правильно оформлен.

Решение

Проверка пути к папке: Убедитесь, что переменная SharedFolder содержит правильный и полный путь к папке. Например, если вы хотите создать директорию на рабочем столе, путь должен выглядеть примерно так:
```
SharedFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ИмяПапки\"
```
Это создаст папку на рабочем столе с именем "ИмяПапки". Замените "ИмяПапки" на желаемое имя.
Использование Dir: Убедитесь, что используете правильную проверку для существования директории. Убедитесь, что после создания папки, путь не заканчивается на обратнослеш ("\").
Коррекция кода:

Sub WO_SaveUpdate()
    Dim WORow As Long, WOCol As Long
    Dim AssignedTo As String, SharedFolder As String, FileName As String, FilePath As String
    Dim FinalPath As String

    With Sheet1
        If .Range("D4").Value = Empty Or .Range("H4").Value = Empty Or .Range("D10").Value = Empty Or .Range("C15").Value = Empty Then
            MsgBox "Please Complete Yellow Boxes"
            Exit Sub
        End If
    End With

    With Sheet3
        If .Range("C4").Value = Empty Then
            MsgBox "Please add in a shared folder location"
            Exit Sub
        End If
    End With

    With Sheet2
        If Worksheets("WO Data").Range("B11").Value = True Then
            WORow = .Range("C99999").End(xlUp).Row + 1
        End If
    End With

    With Sheet1
        For WOCol = 3 To 11
            Sheet2.Cells(WORow, WOCol).Value = .Range(.Cells(30, WOCol).Value).Value
            Sheet4.Range(.Cells(29, WOCol).Value).Value = .Range(.Cells(30, WOCol).Value).Value
        Next WOCol
        Sheet2.Range("B11").Value = False
        Sheet2.Range("B12").Value = WORow

        If .Range("D8").Value = "Open" Then
            AssignedTo = .Range("H4").Value
            SharedFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ИмяПапки\" ' Указываем путь на рабочем столе
            FileName = "Work Order_" & .Range("D6").Value

            If Dir(SharedFolder & AssignedTo, vbDirectory) = "" Then
                MkDir SharedFolder & AssignedTo ' Создание директории
            End If

            FilePath = SharedFolder & AssignedTo & "\" & FileName & ".xlsx"
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0

            Sheet4.Range("A1:B26").Copy
            Workbooks.Add
            ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteAll
            ActiveWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
            ActiveWorkbook.SaveAs FilePath
            ActiveWorkbook.Close False
            Sheet2.Range("G" & WORow).Value = Now
        End If
    End With
End Sub

Заключение

Следуя данным рекомендациям и обеспечивая правильное указание путей, вы сможете успешно создать папки на рабочем столе с использованием VBA. Убедитесь, что права доступа к создаваемой папке настроены корректно, иначе создание директории может не произойти. При возникновении дополнительных вопросов не стесняйтесь задавать их, и удачи с вашим проектом!