excel vba copier la plage de données, ouvrir nouveau fichier xlsx renommer la feuille et enregistrer

Question

J'essaie de nettoyer un peu de code et j'espérais que SO pourrait venir à mon secours une fois de plus. J'ai besoin de copier une gamme, ouvrez un nouveau classeur avec un seul onglet appelé "code de projet - Étiquettes" (code de projet trouvé dans les étiquettes cellule A2 ou A2 du nouveau classeur). Après avoir collé les valeurs et la mise en forme de la source, je souhaite que l'utilisateur choisisse un emplacement de sauvegarde, enregistre le nouveau fichier, ferme le nouveau classeur et retourne au classeur d'origine.

J'ai ajouté des commentaires pour ce que je voudrais faire dans le code ci-dessous

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

Après beaucoup de cheveux tirant et coups de poing bureau, je comprendre cela s'il vous plaît voir le code. accordé cela peut ne pas être le moyen le plus efficace, mais c'est assez rapide et sans erreurs

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