从下拉列表中创建文件夹层次结构中的多个文件副本

Question

我有一个 master Excel sheet 用于吐出工资单的详细信息。工作表上的数字由 A2 中的数据验证下拉列表驱动，该下拉列表使用从数据选项卡中提取的识别信息（Last、First、Region、PayPeriod、Year）填充 B2:G2。

我想做的是让一个宏将下拉列表中每个选项的工作表副本保存到基于 B2:G2 中的信息的层次结构中的特定文件夹中。

例如，

ID    Last    First    Region    PP    Year
10001 Smith   Scott    DC        PP1   2016

我希望将名为“2016_PP1_DC_Smith_Scott.xlsx”的工作表保存在文件夹 C:\2016\PP1\DC 中。

然后改成

ID    Last    First    Region    PP    Year
10002 Jones   Karen    NY        PP3   2015

并将工作表“2015_PP3_NY_Jones_Karen.xlsx”保存在文件夹 C:\2015\PP3\NY 中。

我有一个宏，它是其中的一部分。它遍历每个下拉菜单并使用正确的文件名保存文件（尽管它正在重命名初始文件）（编辑）我需要帮助添加功能以将工作表保存在文件夹层次结构中，而不是用最新的文件覆盖原始文档保存的工作表名称。

继续使用此宏进行编辑或从头开始完全没问题。

Sub PrintValidationChoices()

    Dim wbSource As Workbook
    Dim r As Long, i As Long
    Dim relativePath As String
    Dim year As String
    Dim quarter As String
    Dim pp As String
    Dim region As String
    Dim doctor As String

    Set wbSource = ActiveWorkbook

    r = Range("ID").Cells.Count

        For i = 1 To r
        Range("A2") = Range("ID").Cells(i)

        year = ActiveSheet.Range("G2")
        pp = ActiveSheet.Range("F2")
        region = ActiveSheet.Range("E2")
        hospital = ActiveSheet.Range("D2")
        doctor = ActiveSheet.Range("B2") & "_" & ActiveSheet.Range("C2")

         'visually validating what will be used - not needed
        Range("H3") = year
        Range("H4") = pp
        Range("H5") = region
        Range("H6") = hospital
        Range("H7") = doctor

        sname = year & "_" & pp & "_" & region & "_" & hospital & "_" & doctor & ".xls"
        relativePath = wbSource.Path & "\" & sname 'use path of wbSource

        Range("H8") = relativePath

        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlExcel8
        Application.DisplayAlerts = True

        Application.Wait (Now + TimeValue("00:00:01")) 'pausing to see actions - not needed

        Next i

        Range("A2") = Range("ID").Cells("1") 'return to start of list

    MsgBox "Done!"

End Sub

谢谢大家的帮助！如果您觉得冗长，最好在您的回复中提供一些详细信息，以便我学习。

Answer 1

编辑以反映最可能的验证工作表名称

也许你在追求类似以下的东西：

Option Explicit

Sub main()
    Dim strng As String
    Dim cell As Range

    With Worksheets("Report") '<--| change "Report" to your actual worksheet name
        For Each cell In Range(.Range("a2").Validation.Formula1).SpecialCells(XlCellType.xlCellTypeConstants)
            .Range("a2") = cell.Value
            SaveWorksheet .Range("B2:G2")
        Next cell
    End With
End Sub


Sub SaveWorksheet(rng As Range)
    Dim sname As String, relativePath As String
    Dim folder As String

        folder = "C:\" & rng(1, 6) & "_" & rng(1, 5) & "_" & rng(1, 4)
        MkDir folder

        sname = rng(1, 6) & "_" & rng(1, 5) & "_" & rng(1, 4) & "_" & rng(1, 3) & "_" & rng(1, 2) & "_" & rng(1, 3) & ".xls"
        relativePath = folder & "\" & sname

        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        rng.Parent.Copy
        With ActiveWorkbook
            .SaveAs filename:=relativePath ', FileFormat:=xlExcel8
            .Close
        End With
        Application.DisplayAlerts = True
        Application.Wait (Now + TimeValue("00:00:01")) 'pausing to see actions - not needed
End Sub