从工作表信息创建文件目录

Question

我正在尝试制作一个脚本，根据我在excel中创建的表单信息自动创建文件目录。

文件结构的样子

表单是什么样的

我有一个脚本，在我提取信息后会创建文件目录。我只需要帮助提取信息并将其复制到我的文件目录表上的A列的脚本。表格的A9将始终是文件夹的名称，子文件夹将是产品数据，商店图纸，样品，保证或材料证书。并非所有表格都会包含所有表格。

我的想法是使用if函数，如果工作表有产品数据，它会将A9 / productdata放到文件目录中。我需要它来为工作簿中的每个工作表执行此操作。

Sub FileDirectory()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "File Directory" Then
            ws.Range("A9").Copy Sheets("File Directory").Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next
    Application.ScreenUpdating = True

End Sub

这是我将A9从每个工作表复制到文件目录。我无法弄清楚如何创建if来创建子文件夹。任何帮助将不胜感激！

Answer 1

如果子文件夹名称在A列中，则下面的代码适用于您。

Sub FileDirectory()

Dim ws As Worksheet
Dim subfolders() As String
Dim cell As Range, i As Integer

subfolders = Split("PRODUCT DATA,SAMPLES,SHOP DRAWINGS,MATERIAL CERTIFICATES", ",")

Application.ScreenUpdating = False

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "File Directory" Then
        ws.Range("A9").Copy Sheets("File Directory").Cells(Rows.Count, "A").End(xlUp).Offset(1)
        For Each cell In ws.Range("A:A") 'Changing this cell range to a smaller, defined range will improve performance
            For i = LBound(subfolders) To UBound(subfolders)
                If cell.Value = subfolders(i) Then
                    Sheets("File Directory").Cells(Rows.Count, "A").End(xlUp).Offset(1) = ws.Range("A9").Value + "/" + cell.Value
                End If
            Next i
        Next cell
    End If
Next

Application.ScreenUpdating = True

End Sub