Question

我有一个master Excel sheet旨在吐出工资单细节。工作表上的数字由A2中的数据验证下拉列表驱动，该下拉菜单填写B2：G2，其中包含从数据选项卡中提取的识别信息（Last，First，Region，PayPeriod，Year）。

我想要做的是根据B2：G2中的信息，将下拉列表中每个选项的工作表副本保存到层次结构中的特定文件夹中。

例如，

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

我希望保存一张名为＆＃34; 2016_PP1_DC_Smith_Scott.xlsx＆＃34;在文件夹C：\ 2016 \ PP1 \ DC。

中

然后转到

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

并保存表格＆＃34; 2015_PP3_NY_Jones_Karen.xlsx＆＃34;在文件夹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

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

1 个答案: