excel vba copy data range, откройте новый файл переименования xlsx и сохраните

Question

Я пытаюсь очистить немного кода, и я надеялся, что SO снова придет мне на помощь. Мне нужно скопировать диапазон, открыть новую книгу с помощью только одной вкладки под названием «код проекта - ярлыки» (код проекта, найденный в ячейке листа ярлыков 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 

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