excel vba复制数据范围，打开新的xlsx文件重命名表并保存

Question

我试图清理一些代码，我希望能再来一次救援。我需要复制一个范围，打开一个新工作簿，只有一个名为＆＃34;项目代码 - 标签＆＃34; （在新工作簿的标签表单元格A2或A2中找到的项目代码）。粘贴值和源格式后，我想提示用户选择保存位置，保存新文件，关闭新工作簿并返回原始工作簿。

我在下面的代码中添加了我想要做的评论

Sub GenLabels()

Application.ScreenUpdating = False
Worksheets("HR-Cal").Activate
Range("u100000").End(xlUp).Select
Range("ap2") = ActiveCell.Row

Worksheets("Labels").Activate
Dim rng As Range
Dim lab As String

    Rows("3:" & Range("as1")).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2:AP2").AutoFill Destination:=Range("A2:AP" & Range("as1")), Type:=xlFillDefault
    Range("A2:AP32").End(xlDown).Select
 Range("a100000").End(xlUp).Activate
 Range("at1") = ActiveCell.Row

 lab = ("A2:AP" & Range("at1"))
 Set rng = Range(lab)
 rng.Select

    ActiveWorkbook.Worksheets("Labels").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Labels").Sort.SortFields.Add Key:=Range("X2:X" & Range("at1")) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Labels").Sort
        .SetRange Range("a1:ap" & Range("at1"))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    For lrow = Cells(Cells.Rows.Count, "X").End(xlUp).Row To 1 Step -1
    If Cells(lrow, "X") = 0 Then
            Rows(lrow).EntireRow.Delete
    End If
Next lrow

    For lrow = Cells(Cells.Rows.Count, "D").End(xlUp).Row To 1 Step -1
    If Cells(lrow, "D") = 0 Then
            Rows(lrow).EntireRow.Delete
    End If
Next lrow

Range("A1:AP1").End(xlDown).Copy
Application.ScreenUpdating = True

' msgbox that allows user to check filtered data and only runs the rest of the macro
' if they click OK

msgbox("If Label data looks correct please press OK to continue, or CANCEL to stop",vbOKCancel)

If vbCancel Then
        End Sub

Else

'Code to paste only values and formatting into new workbook
    Worksheets("Labels").Activate
    Range("A1:AP1").End(xlDown).Copy
    Sheets("Labels").Select

    ' create new workbook with only one sheet
    Workbooks.Add

    'paste label data
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

 ' prompt user to choose file save location, with file name PROJECT CODE - Labels

        ActiveWorkbook.SaveAs Filename:="v:\Users\lies\NotReal\J31 Labels.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

' save and close new workbook

'return to orginal workbook
Worksheets("Labels").Activate
Range("A2").Select

End Sub