简体   繁体   中英

Export sheet to XLS without copying VBA - have existing code using copy, need help copying by range

I have a "main" workbook that has several tabs for several different order processing tasks. I past data, run some macros that format or add columns based on values. Then I export the current worksheet to new predefined XLS file named based on cell value variables. Eg - there's a "setting" sheet that contains the path and filename of the exported sheet.

I've been using the following code which was based on someone's forum post, slightly modified. It uses the old file save method (which sometimes crashes randomly), yes I know, but I don't know how to write newer code.

The problem is that these sheets show a user form on active that has buttons to do the tasks. When the sheet is exported to the new XLS it's done by the copy sheet method, which carries over the VBA "worksheet.activate" code. When the new book opens it tries to run the userform which doesn't exist.

I found code that tried to delete the VBA here and on other forums, and I enabled the trusted VBA model option in the trust center, but it doesn't work. So, basically, I need help with finding a way to export the sheet's active ranges (there are no blank lines) to the new XLS file (which gets overwritten every day so technically it's not a "new file") using the cell values, not the worksheet.copy method.

Public Sub PrintExport()
Dim rng As Range
Dim wkb As Workbook
Dim sht As Worksheet
Dim EXPath As String

EXPath = ThisWorkbook.Worksheets("Settings").Range("B2")

Range("A2").Select
    If Range("A2") = "" Then
        MsgBox ("Not enough data.")
Exit Sub
Else

Set rng = ActiveSheet.UsedRange
On Error GoTo 0

    If Not rng Is Nothing Then
        fileSaveName = Application.GetSaveAsFilename(InitialFileName:=EXPath, filefilter:="xls Files (*.xls),*.xls,")


        'Application.GetSaveAsFilename(fileFilter:="xls Files (*.xls), *.xls")
        If fileSaveName <> False Then

            ActiveSheet.Copy
            Set wkb = ActiveWorkbook
            Set sht = wkb.ActiveSheet
            ActiveSheet.Name = "sheet1"
            sht.Cells.Delete
            rng.Copy sht.Range("A1")
          'this is where I tried the VBA delete code
            wkb.SaveAs fileSaveName, FileFormat:=xlExcel8
            wkb.Close
        End If
    End If
End If

I tried this VBA delete code but no luck.

    With ThisWorkbook.VBProject.VBComponents(strName).CodeModule

                        .DeleteLines 1, .CountOfLines

Assuming that the "A2" range you are referring to is on the "Settings" sheet you can bypass selecting it first by just referencing it like:

If Sheets("Settings").Range("A2") = "" Then MsgBox ("Not enough data.") Exit Sub Else

Also, not sure why you are using fileSaveName = Application.GetSaveAsFilename when I'm assuming you want the file to be named as defined above in the EXPath string. Knowing that your workbook has more than one worksheet I would cycle through all worksheets to remove all vba code, external links, hyperlinks and formulas. (Make adjustments here as necessary).

Dim EXPath As String
Dim nr As Name ' use this if you want to delete named ranges
Dim ws As Worksheet

EXPath = ThisWorkbook.Sheets("Settings").Range("F4") "set saved file name

    Sheets(Array("Settings")).Copy 'setup array of sheets w just the one sheet
On Error GoTo 0

    For Each ws In ActiveWorkbook.Worksheets
        ws.Cells.Copy
        ws.[A1].PasteSpecial Paste:=xlValues
        ws.Cells.Hyperlinks.Delete
        Application.CutCopyMode = False
        Cells(1, 1).Select
        ws.Activate
    Next ws
    Cells(1, 1).Select

     'Remove named ranges
    For Each nr In ActiveWorkbook.Names
        nr.Delete
    Next nr

     'Get rid of images,shapes w code
    ActiveSheet.Shapes.SelectAll
    Selection.Delete

    ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & EXPath & ".xlsx" 'modify this line
    ActiveWorkbook.Close savechanges:=False

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM