Importing .BAS to Sheet Object... NOT Class Module?

[crabby09]

Hi Guys,

Been trawling though all the posts and appear to have found something that hasn't already been answered (long shot I know!).

Here's my full code:

Sub SalesPersonCopy()
    Dim Sh As Worksheet
    Dim Master As Workbook
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim WB As Workbook
    Dim MSG1 As Integer
    Dim MSG2 As Integer
    Dim Shp As Shape
    Dim FName As String
    
'check to ensure user wants to continue
MSG1 = MsgBox("This will produce seperate Excel review documents for each Sales Person, and will take some time. Are you sure you want to continue?", vbYesNo, "Do you want to continue?")

If MSG1 = vbYes Then

MSG2 = MsgBox("This will overide any previous files that have been produce today. Are you sure you want to continue?", vbYesNo, "Do you want to continue?")

If MSG2 = vbYes Then
    
'set update perameters to speed up calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.CalculateBeforeSave = False
    Application.DisplayAlerts = False
    
'set up the copy workbook
    Set Master = ThisWorkbook
    Set Sh = Worksheets("Sage Update Summary")
    Sh.Unprotect
    Set Rng = Sh.Range("B8:B" & Sh.Range("A1048576").End(xlUp).Row)
    
'Produce a list of unique sales people
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    
'set copy range
    Set Rng = Sh.Range("A7:GT" & Sh.Range("A1048576").End(xlUp).Row)
    
'copy each sales persons filtered lines to seperate worksheet
    For Each Item In List
        Set WB = Workbooks.Add
        Sh.Range("A1:GT6").Copy WB.Worksheets(1).Range("A1")
        Rng.AutoFilter Field:=2, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A7")
        
'add back revenue formulae
        WB.Worksheets(1).Range("DF8:" & "DH" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("DM8:" & "DO" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("DT8:" & "DV" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("EA8:" & "EC" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("EH8:" & "EJ" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("EO8:" & "EQ" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("EV8:" & "EX" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("FC8:" & "FE" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("FJ8:" & "FL" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("FQ8:" & "FS" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("FX8:" & "FZ" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
        WB.Worksheets(1).Range("GE8:" & "GG" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=RC[-94]*RC104"
       
'add in total formulae
        WB.Worksheets(1).Range("L" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row + 2 & ":GR" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row + 2).FormulaR1C1 = "=SUBTOTAL(109,R8C:R[-1]C)"
        WB.Worksheets(1).Range("GH8:" & "GN" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=SUMIF(R7C97:R7C180,R7C,RC97:RC180)"
        WB.Worksheets(1).Range("GP8:" & "GQ" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).FormulaR1C1 = "=SUM(RC183:RC187)-RC[-8]"
        
'format the total formulae
        With WB.Worksheets(1).Range("L" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row & ":GR" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
        End With
        With WB.Worksheets(1).Range("L" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row & ":GR" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThick
        End With
        WB.Worksheets(1).Range("L" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row & ":GR" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).Style = "Comma"
        WB.Worksheets(1).Range("L" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row & ":GR" & WB.Worksheets(1).Range("L1048576").End(xlUp).Row).Font.Bold = True
        
'resize the columns
        WB.Worksheets(1).Columns("A").ColumnWidth = 32
        WB.Worksheets(1).Columns("B").ColumnWidth = 14
        WB.Worksheets(1).Columns("C").ColumnWidth = 11.75
        WB.Worksheets(1).Columns("D").ColumnWidth = 13.88
        WB.Worksheets(1).Columns("E").ColumnWidth = 29
        WB.Worksheets(1).Columns("F").ColumnWidth = 14
        WB.Worksheets(1).Columns("G").ColumnWidth = 17
        WB.Worksheets(1).Columns("H").ColumnWidth = 32.75
        WB.Worksheets(1).Columns("I").ColumnWidth = 21
        WB.Worksheets(1).Columns("J").ColumnWidth = 6.75
        WB.Worksheets(1).Columns("K").ColumnWidth = 1.75
        WB.Worksheets(1).Columns("L:GT").ColumnWidth = 17.25
        WB.Worksheets(1).Columns("CY").ColumnWidth = 1.75
        WB.Worksheets(1).Columns("DA").ColumnWidth = 1.75
        WB.Worksheets(1).Columns("GO").ColumnWidth = 1.75
        WB.Worksheets(1).Columns("GS").ColumnWidth = 1.75
        WB.Worksheets(1).Columns("GT").ColumnWidth = 70
        WB.Worksheets(1).Rows("7").AutoFilter
        
'remove macro button
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next Shp
        
'fix the window zoom to 70%
        ActiveWindow.Zoom = 70
        
'Remove the filter on original data
        Rng.AutoFilter
        
'copy sheet macro
    With Master
    FName = .Path & "code.bas"
    .VBProject.VBComponents("Sheet6").Export FName
    End With
    WB.VBProject.VBComponents.Import FName
    Kill FName
        
'save the new workbook with unique name based upon sales person
        With WB
            .SaveAs ThisWorkbook.Path & "\Sales Forecast Sheet - " & Format(Now(), "ddmmyy") & " - " & Item & ".xlsm", FileFormat:=52, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
            .Close
        End With
    Next Item
    
'once complete, return to original data and refilter
    Sh.Activate
    Sh.Rows("7").AutoFilter
    
'remove update parameters to bring Excel back to standard state
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.CalculateBeforeSave = True
    Application.DisplayAlerts = True

'protect sheet
Sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowInsertingRows:=True, AllowFiltering:=True, AllowSorting:=True
Application.ScreenUpdating = True
    
MsgBox "The process has completed successfully, please check the folder for distributable reports.", , "Process Complete"
    
Else
End If
Else
End If
End Sub

I am copying a load of filtered data to separate worksheets for use by different sales people... They're bound to try and break things, so their final files have protection enabled... They need to be able to insert extra rows of data, so I have built a macro that unprotects and copies various formulas to the inserted row when it detects a row is inserted. Here's the code for the macro I wish to insert into the sheet object:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count = 16384 Then
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.CalculateBeforeSave = False
    Application.DisplayAlerts = False
ActiveSheet.Unprotect
Range("CR" & Target.Row & ":GR" & Target.Row).Offset(-1, 0).Select
Selection.Copy
Range(ActiveCell.Address).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("CZ" & Target.Row) = 1
Range("DB" & Target.Row & ":DE" & Target.Row) = 0
Range("DI" & Target.Row & ":DL" & Target.Row) = 0
Range("DP" & Target.Row & ":DS" & Target.Row) = 0
Range("DW" & Target.Row & ":DZ" & Target.Row) = 0
Range("ED" & Target.Row & ":EG" & Target.Row) = 0
Range("EK" & Target.Row & ":EN" & Target.Row) = 0
Range("ER" & Target.Row & ":EU" & Target.Row) = 0
Range("EY" & Target.Row & ":FB" & Target.Row) = 0
Range("FF" & Target.Row & ":FI" & Target.Row) = 0
Range("FM" & Target.Row & ":FP" & Target.Row) = 0
Range("FT" & Target.Row & ":FW" & Target.Row) = 0
Range("GA" & Target.Row & ":GD" & Target.Row) = 0
Range("A" & Target.Row).Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowInsertingRows:=True, AllowFiltering:=True, AllowSorting:=True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.CalculateBeforeSave = True
    Application.DisplayAlerts = True
End If
End Sub

You can see in the "copy sheet macro" of my first code that I am copying the macro from Sheet6... I then want to paste it into Sheet1 of the new workbook:

'copy sheet macro
    With Master
    FName = .Path & "code.bas"
    .VBProject.VBComponents("Sheet6").Export FName
    End With
    WB.VBProject.VBComponents.Import FName
    Kill FName

Unfortunately, this creates a class module which means it doesn't activate when a row is inserted on Sheet1. When I try and define the VBComponents as Sheet1 the macro breaks stating "Object doesn't support this property or method".

Thanks for any help you guys can give!!!

crabby

[romperstomper]

It is simpler to use a template workbook with the code already in place.

[crabby09]

So, it's really that hard? I'll change my code to use a template, but would love to understand why it's so easy to export from any object but so hard to import?

Thanks,

crabby

[romperstomper]

Because the worksheet already has a code module. The Import function only creates new modules - it won't replace an existing one.

[crabby09]

Well.. That's me learnt!

I simply produced a blank sheet in my master document with the macro embedded and changed my formula to this:

'copy each sales persons filtered lines to seperate worksheet
    For Each Item In List
        Master.Worksheets(8).Copy
        Set WB = ActiveWorkbook
        Sh.Range("A1:GT6").Copy WB.Worksheets(1).Range("A1")
        Rng.AutoFilter Field:=2, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A7")

Thanks,

crabby