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

Question

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

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

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

Answer 1

经过大量拉头发和敲桌子后，我想通了，请参阅代码。当然这可能不是最有效的方法，但它相当快且没有错误

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").Select

    Selection.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

Dim last As String
Range("a100000").End(xlUp).Activate
last = ActiveCell.Row
   Range("A1:AP" & last).Copy

'Application.ScreenUpdating = True

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = ActiveSheet.Range("A2") & " " & Range("Z2") & " - Labels"

    'Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Columns.AutoFit
    ActiveWindow.Zoom = 80
    Range("A1").Select
    ActiveSheet.Select
    Application.CutCopyMode = False
    ActiveSheet.Move

'
    ActiveSheet.Name = ActiveSheet.Range("A2") & " " & Range("Z2") & " - Labels"
Application.ScreenUpdating = True

Dim bFileSaveAs As Boolean
    bFileSaveAs = Application.Dialogs(xlDialogSaveAs).Show

End Sub