Блог

Я ищу способы создания папок из ячеек excel, которые будут автоматически обновляться при вводе новых значений в ячейку. Мне также нужны эти папки для синхронизации SharePoint .

До сих пор я пробовал различные методы, включающие модули VBA, которые, похоже, не работают, когда должны, и я использовал kutools , который создает папки, но должен обновляться вручную при создании новых ячеек (также не синхронизируется с SharePoint или не работает на любом другом устройстве без kutools).

Я попробовал это:

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call MakeFolders
        End If
    Next
    Application.EnableEvents = True
End Sub

Sub MakeFolders()
    Dim Rng As Range
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim maxRows As Integer
    Dim r As Integer
    Dim c As Integer
    Set sht = Worksheets("Sheet1")
    Set StartCell = Range("A1")
    LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
    LastColumn = 1
    sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    For c = 1 To 1
        r = 1
        Do While r <= maxRows
            If Len(Dir(ActiveWorkbook.Path amp; "" amp; Rng(r, c), vbDirectory)) = 0 Then
                MkDir (ActiveWorkbook.Path amp; "" amp; Rng(r, c))
                On Error Resume Next
            End If
        r = r   1
        Loop
    Next c
    Range("A" amp; Rows.Count).End(xlUp).Offset(1).Select
End Sub
 

Похоже, вы определяете, сколько изменений было внесено в столбец А, и вам Target нужно сообщить, что это такое, но затем вы пытаетесь создать папки для каждой записи в столбце А, повторно основываясь на том, сколько изменений было внесено.

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

Попробуйте что-нибудь вроде этого:

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cellchange As Range
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Each cellchange In Intersect(Target, Range("A:A")).Cells
        If cellchange.Value <> "" Then
            MakeFolders ActiveWorkbook.Path amp; "" amp; cellchange.Value
        End If
    Next
    Application.EnableEvents = True
End Sub

Sub MakeFolders(folderpath As String)
    If Len(Dir(folderpath, vbDirectory)) = 0 Then
        MkDir (folderpath)
    End If
End Sub
 

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