Saving worksheets (trailing from 1 to specified last number) as a new workbook M

Question

Saving worksheets (trailing from 1 to specified last number) as a new workbook

My workbook (after the main macro has run) has "Sheet1" and then 'i' number of sheets named "Slicei" where i ranges from 1 to a defined number (called LastTier). These "Slice" sheets are the ones I wish to save together as a new workbook (they also appear before Sheet1 in the current workbook).

I need to create a macro that will select only those sheets whose name contains "Slice" and save them together as a new workbook whose name needs to be "Client & TankNum".

Also, the name for the "Slice" sheets is set within the main macro (which I do not want to call in this second macro). I want this macro to run when the user is ready to run it. However, the variables/dimensions used in this second macro are already set within the main macro (LastTier, Client and TanNum). My full main macro is below:

Sub Main2()

Dim Message As String
Dim Client As String
Dim StartDate As Date
Dim TankNum As String
Dim TankHeight As String
Dim LastTier As Integer
Dim increment As Integer

Dim Response As Long
Dim Msg As String
Dim Style As String
Dim Help As String
Dim Ctxt As Integer
Dim Tier As Integer

Dim K As Integer
Dim ender As Integer
Dim last As String
Dim starter As Integer
Dim sheetname1 As String
Dim Range1 As Range

Dim Devm As Single
Dim Rad As Double
Dim slice As String
Dim point As String
Dim Angle As Double
Dim Devmm As Integer
Dim height As String

Dim MainRange As Range
Dim CalcMode As Long
Dim ViewMode As Long
Dim sheetname2 As String
Dim SliceHeight As String

Message = "Enter Client name"
Client = InputBox(Message, Title)

Message = "Enter the Tank ID"
TankNum = InputBox(Message, Title)

Message = "Enter job Start Date as dd/mm/yy"
StartDate = InputBox(Message, Title)

Message = "Enter the Full height of Tank"
TankHeight = InputBox(Message, Title)

Message = "Enter the number of slices"
LastTier = InputBox(Message, Title)

Message = "Enter the number of points"
increment = InputBox(Message, Title)

' ***********************************************************************
Do Until Response = vbNo
Msg = "Do you want to chart a slice?"
Style = vbYesNo + vbDefaultButton2
Help = "DEMO.HLP"
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbNo Then
Exit Do
Exit Sub
End If

Message = "Enter required slice number from 1 to " & LastTier
Tier = InputBox(Message, Title)
If IsNull(Tier) Then
Exit Sub
End If

K = 1
ender = Tier * increment
last = LastTier * increment
starter = ender - (increment - 1)
If starter = 0 Then
starter = 1
End If

sheetname1 = "Sheet1"
ActiveSheet.Name = sheetname1
ActiveSheet.Range("K2") = TankHeight
ActiveSheet.Range("K3") = LastTier - 1
ActiveSheet.Range("K4").Formula = "=$K$2/$K$3"
ActiveSheet.Range("K6").Value = 360
ActiveSheet.Range("K7") = increment
ActiveSheet.Range("K8").Formula = "=$K$6/$K$7"

Set Range1 = Range("A1:J" & (last + 10))
With Range1
Rows(last + 2).Delete
End With

For K = starter To ender
Devm = ActiveSheet.Range("A" & K).Value
Rad = ActiveSheet.Range("B" & K).Value
slice = ActiveSheet.Range("C" & K).Value
point = ActiveSheet.Range("D" & K).Value
' ***Automation settings for Formulas and Autofill - all in one***
ActiveSheet.Range("E1:E" & last).Formula = "=(D1-1)*$K$8"
ActiveSheet.Range("F1:F" & last).Formula = "=A1*1000"
ActiveSheet.Range("G1:G" & last).Formula = "=(C1-1)*$K$4"
Angle = ActiveSheet.Range("E" & K).Value
Devmm = ActiveSheet.Range("F" & K).Value
height = ActiveSheet.Range("G" & K).Value

K = K + 1

ActiveSheet.Range("C1").Select

Next

Set MainRange = ActiveSheet.Range("C1:G" & K)
MainRange.Parent.Select
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = True
.EnableEvents = False
End With

ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

MainRange.Parent.AutoFilterMode = False
MainRange.AutoFilter Field:=1, Criteria1:="=" & Tier

Sheets.Add
sheetname2 = "Slice" & Tier
ActiveSheet.Name = sheetname2
MainRange.Parent.AutoFilter.Range.Copy
With ActiveSheet.Range("A1")
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
If Tier > 1 Then
Rows(1).Delete
End If
End With

SliceHeight = ActiveSheet.Range("E2").Value
ActiveSheet.Range("A" & (increment + 1)).Formula = "=A1"
ActiveSheet.Range("B" & (increment + 1)).Formula = "=B1"
ActiveSheet.Range("C" & (increment + 1)).Formula = "=C1 + 360"
ActiveSheet.Range("D" & (increment + 1)).Formula = "=D1"
ActiveSheet.Range("E" & (increment + 1)).Formula = "=E1"

MainRange.Parent.AutoFilterMode = False
MainRange.Parent.Select
ActiveWindow.View = ViewMode
Call deviationcharts(Title, Client, StartDate, TankNum, increment, Tier, sheetname2, SliceHeight)
Sheets("Sheet1").Select

Loop
End Sub

Explanation / Answer

=========>

To avoid your macro becoming unwieldy, try pushing the code to create and save the new workbook into a new procedure and call the new procedure from your existing macro. Therefore, something like:

In your existing macro, at the desired point, insert the instruction:

   Call Tester(Tanknum, Client)

and paste the following additional routine into your code module:

'==========>>
Public Sub Tester(myTanknum, sClient)
    Dim WB As Workbook, newWB As Workbook
    Dim SH As Worksheet
    Dim Arr() As Variant
    Dim i As Long

    Set WB = ThisWorkbook
    For Each SH In WB.Worksheets
        With SH
            If UCase(Left(.Name, 5)) = UCase("Slice") Then
                i = i + 1
                ReDim Preserve Arr(1 To i)
                Arr(i) = .Name
            End If
        End With
    Next SH
    WB.Sheets(Arr).Copy
    Set newWB = ActiveWorkbook
    newWB.SaveAs Filename:=sClient & myTanknum & ".xlsx", FileFormat:=51
End Sub
'<<=============

Related Questions

Navigate

• Browse (All)
• Browse S
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.