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

Question

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

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

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

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

excel vba copy data range, open new xlsx file rename sheet and save

excel

user-input

prompt

save-as

vba