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

Question

I'm trying to clean up a bit of code and I was hoping SO could come to my rescue once again. I need to copy a range, open a new workbook with only one tab called "project code - Labels" (project code found in labels sheet cell A2 or A2 of new workbook). After pasting values and source formatting, I'd like to propmt the user to choose a save location, save the new file, close new workbook and return to the original workbook.

I have added comments for what I'd like to do in the code below

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

score 0 · Accepted Answer · answered Oct 09 '15 at 18:11

After lots of hair pulling and desk punching I figure this out please see code. granted this may not be the most efficient way but its fairly fast and without errors

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 copy data range, open new xlsx file rename sheet and save

1 Answers1