Save Created sheet with different name

pantakos · Feb 18th 2022

Hello ,

The code below is working fine and creates a new sheet.

The newly created sheet is saved by a constant name.

Can be saved with the name of the sheet whEre the new sheet created plus a number (or no number just the name).

(i,e. the name of the sheet that will get data and create a new sheet named 1.Power Distribution - Dimmer, so the new workgroup saved as this name)

I have uploaded example. The module need to be changed is Module5

Thanks

rollis13 · Feb 18th 2022

Could be a quick (static) solution:

Code

'...
Dim N$
N = ActiveWorkbook.Path & "\" & Worksheets("1.Power Distribution - Dimmer").Name & ".xlsx" '<- changed
Sheets(S).Move
'...

pantakos · Feb 19th 2022

rolls13. Thank you for your answer.

I havent test the solution but I need name to be the active worksheet, the one I am retrieving the data from. It may be 1.Power Distribution - Dimmer or 2.PowerCycle2 or 3.Dimmers . the newly created sheet take the name of the sheet from the data is retrieved.

rollis13 · Feb 19th 2022

As said it would be static since the name of the sheet is hardcode and was already in your macro, here:

For Each cell In Worksheets("1.Power Distribution - Dimmer").Range("D5:D9, ...

How will the macro work with other sheet names ?

So, all you have to do is create a new variable (example: shtName) at the beginning and assign to it the name of the active sheet to be used here in the For/Each and later down in the macro when you assign to the variable N the path and the name of the file to be saved.

Maybe:

Code

Sub BuildTemplateINm()
    Dim i      As Long, j As Long, nr As Long
    Dim cell   As Variant, f As Range
    Dim Descript As String
    Dim shtName As Worksheet                      '<- added
    Set shtName = ActiveSheet                     '<- added
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets.Add.Name = "NewSheet"
    Worksheets("NewSheet").Range("A1").Value = "Description"
    Worksheets("NewSheet").Range("B1").Value = "Quantity"
    nr = 1
    Sheets("NewSheet").Range("A2:B150").ClearContents
    For Each cell In Worksheets(shtName.Name).Range("D5:D9, D11:D20, D22:D32, D34:D46, D48:D53, D55:D62, D64:D71, D73:D84, D86:D97") '<- changed
        If cell > 0 Then
            Descript = cell.Offset(0, -1)
            With Sheets("NewSheet")
                Set f = .Range("A2:A150").Find(Descript, , xlValues, xlWhole)
                If Not f Is Nothing Then
                    nr = f.Row
                Else
                    nr = nr + 1
                    If nr > 150 Then
                        MsgBox "Rows are full"
                        Exit Sub
                    End If
                End If
                .Cells(nr, "A") = Descript
                .Cells(nr, "B") = cell
            End With
        End If
    Next cell
    Application.ScreenUpdating = False
    Const S = "NewSheet"
    Dim N$
    N = ActiveWorkbook.Path & "\" & shtName.Name & ".xlsx" '<- changed
    Sheets(S).Move
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs N, 51
    Application.DisplayAlerts = True
End Sub

Display More

pantakos · Feb 19th 2022

Yes that will do the job! Thank you @rollis13 !!!

rollis13 · Feb 19th 2022

Thanks for the positive feedback, glad having been of some help.

pantakos · Feb 19th 2022

@rollis13 is it possible to ask for something else for the same code?

I have change the current code to working only for column D , and copy values but also copy formatting. I am stuck! Can only copy values? not formatting.

Code

Sub BuildTemplateINm()
 Dim i As Long, j As Long, nr As Long
 Dim sht As Variant
 Dim cell As Variant, f As Range
 Dim Descript As String
 Dim shtName As Worksheet '<- added
 Set shtName = ActiveSheet  '<- added
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Sheets.Add.Name = "NewSheet"
 Worksheets("NewSheet").Range("A1").Value = "Description"
 Worksheets("NewSheet").Range("B1").Value = "Quantity"
 nr = 2
 sht = Array("D")
 ws = Array("1.Power Distribution - Dimmer", "2.POWER CABLES - ADAPTORS  ", "3.CABLES (OTHER) - CABLE CROSS ")
 Sheets("NewSheet").Range("A2:B150").ClearContents
  'Loop through all sheets in sheets array
    For i = LBound(ws) To UBound(ws)
'       Loop through all columns in the column array
        For c = LBound(sht) To UBound(sht)
'           Find last row in column with data
            Sheets(ws(i)).Activate
            lr = Cells(Rows.Count, sht(c)).End(xlUp).Row
'           Loop through all cells in column
            For Each cell In Range(Cells(1, sht(c)), Cells(lr, sht(c)))
'               Check to see if value is numeric and not 0
                If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then
'                   Copy cells C, D, E to columns A, B, C of main sheet
                    Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy Sheets("NewSheet").Cells(nr, "A")
'                   Increment nr counter
                    nr = nr + 1
'                   'Check to see if rows are full
                    'If nr > 70 Then
                        'MsgBox "Rows are full"
                        'Exit Sub
                    'End If
                End If
            Next cell
        Next c
    Next i
 
 Application.ScreenUpdating = False
 Const S = "NewSheet"
 Dim N$
 N = ActiveWorkbook.Path & "\" & shtName.Name & ".xlsx" '<- changed
 Sheets(S).Move
 Application.DisplayAlerts = False
 ActiveWorkbook.SaveAs N, 51
 Application.DisplayAlerts = True
End Sub

Display More

I think I have to change code line

Code

Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy Sheets("NewSheet").Cells(nr, "A")

I think I have to add

Code

PasteSpecial Paste:=xlPasteValues

But I am confused...

Thank you !

rollis13 · Feb 19th 2022

Yes, but you need to divide the line of code like this:

Code

Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy
Sheets("NewSheet").Cells(nr, "A").PasteSpecial Paste:=xlPasteValues

rollis13 · Feb 19th 2022

I would also fix this, at the beginning you set it False then before ending your macro turn it back to True:

Code

'...
Next i
Application.ScreenUpdating = True             '<- fixed
Const S = "NewSheet"
'...

pantakos · Feb 19th 2022

You are the man ! Thank you very much ! Really appreciate that !

pantakos · Feb 20th 2022

@rollis13 One more LAST help. (As you can understand I am newbie and trying to understand and learn). The code is working fine (extremely fine) but when I am trying to create a new Template, it all what it needs to do, but when I create the first template from sheet 1 (1.Power Distribution - Dimmer) working fine. When I am trying to create an other template (lets say from sheet 2.POWER CABLES - ADAPTORS) it appends the result to NewSheet (I dont know where finds it as it has been rename and moved) and creates the new Template with data from both sheets (append the results from both sheets, or all sheets that have data at column D).

I cant figure out why this happens, Maybe needs to make a "refresh" and delete all the other data from memory. I dont know. I am trying all night to figure out.

I attach the example for you. Thank you !

pantakos · Feb 20th 2022

Here is the example file again, this time without password for code

rollis13 · Feb 20th 2022

Quote from pantakos

'Loop through all sheets in sheets array
For i = LBound(ws) To UBound(ws)

Here you are looping through all the sheets but the loop ends before the code that saves the new file. That means that the new file will always contain copy of all the sheets. Move the line Next i to the end of the macro and move the lines Set shtName = ActiveSheet and nr = 2 just inside the For i loop.

Leave it to you to spot/fix any other issues (probably there won't be any).

pantakos · Feb 20th 2022

@rollis13 Unfortenetly I cant make it work

The code is this one now

Code

Sub BuildTemplateINm()
 Dim i As Long, j As Long, nr As Long
 Dim sht As Variant
 Dim cell As Variant, f As Range
 Dim Descript As String
 Dim shtName As Worksheet '<- added
 'Set shtName = ActiveSheet  '<- added
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Sheets.Add.Name = "NewSheet"
 Worksheets("NewSheet").Range("A1").Value = "Description"
 Worksheets("NewSheet").Range("B1").Value = "Quantity"
 'nr = 2
 sht = Array("D")
 ws = Array("1.Power Distribution - Dimmer", "2.POWER CABLES - ADAPTORS  ", "3.CABLES (OTHER) - CABLE CROSS ")
 Sheets("NewSheet").Range("A2:B150").ClearContents
  'Loop through all sheets in sheets array
    For i = LBound(ws) To UBound(ws)
    Set shtName = ActiveSheet  '<- added
      nr = 2
'       Loop through all columns in the column array
        For c = LBound(sht) To UBound(sht)
'           Find last row in column with data
            Sheets(ws(i)).Activate
            lr = Cells(Rows.Count, sht(c)).End(xlUp).Row
'           Loop through all cells in column
            For Each cell In Range(Cells(1, sht(c)), Cells(lr, sht(c)))
'               Check to see if value is numeric and not 0
                If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then
'                   Copy cells C, D, E to columns A, B, C of main sheet
                    'Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy Sheets("NewSheet").Cells(nr, "A")
                    
                    Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy
                    Sheets("NewSheet").Cells(nr, "A").PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
'                   Increment nr counter
                    nr = nr + 1
'                   'Check to see if rows are full
                    'If nr > 70 Then
                        'MsgBox "Rows are full"
                        'Exit Sub
                    'End If
                End If
            Next cell
        Next c
   Next i

 Application.ScreenUpdating = False
 Const S = "NewSheet"
 Dim N$
 N = ActiveWorkbook.Path & "\" & shtName.Name & ".xlsx" '<- changed
 Sheets(S).Move
 Application.DisplayAlerts = False
 ActiveWorkbook.SaveAs N, 51
 Application.DisplayAlerts = True

End Sub

Display More

pantakos · Feb 20th 2022

@rollis13 And another one. It keeps getting the name from sheet no2 2.POWER CABLES - ADAPTORS

Strange !

rollis13 · Feb 20th 2022

Also done some cleaning out, have a try:

Code

Option Explicit
Sub BuildTemplateINm()
    Dim i      As Long, nr As Long
    Dim cell   As Variant
    Dim ws     As Variant, lr As Long
    Dim wkb    As Workbook
    Dim N$
    Set wkb = ActiveWorkbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ws = Array("1.Power Distribution - Dimmer", "2.POWER CABLES - ADAPTORS", "3.CABLES (OTHER) - CABLE CROSS")
    ' Loop through all sheets in sheets array
    For i = LBound(ws) To UBound(ws)
        wkb.Sheets(ws(i)).Activate
        Sheets.Add.Name = "NewSheet"
        Range("A1").Value = "Description"
        Range("B1").Value = "Quantity"
        nr = 2
        Sheets(ws(i)).Activate
        ' Find last row in column with data
        lr = Cells(Rows.Count, "D").End(xlUp).Row
        ' Loop through all cells in column
        For Each cell In Sheets(ws(i)).Range(Cells(1, "D"), Cells(lr, "D"))
            ' Check to see if value is numeric and not 0
            If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then
                ' Copy cells C, D, E to columns A, B, C of newsheet
                Range(Cells(cell.Row, "C"), Cells(cell.Row, "E")).Copy
                Sheets("NewSheet").Cells(nr, "A").PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
                ' Increment nr counter
                nr = nr + 1
            End If
        Next cell
        N = ActiveWorkbook.Path & "\" & ws(i) & ".xlsx"
        Sheets("NewSheet").Move
        ActiveWorkbook.SaveAs N, 51
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Done!"
End Sub

Display More

pantakos · Feb 20th 2022

At this line

wkb.Sheets(ws(i)).Activate

Gets an error 9 Subscript out of range

pantakos · Feb 20th 2022

Oh ok! Sheet no2 have a " " at the end ADAPTORS . So I correct this, but now it says that NewSheet already exists and yes there is a sheet by that name, at the newly created workgroup and the sript stops.

rollis13 · Feb 20th 2022

There was an extra space at the end of sheet "3. ...." too.

Yes, if the macro gets interrupted you need to manually delete the "Newsheet" but you could implement, at the beginning of the macro, a check if there already is a sheet named Newsheet and delete it before proceeding. But this can only happen while testing, once the macro is definitve this should no longer occur.

pantakos · Feb 20th 2022

Yes, You are absolutely correct (as anytime...) Everything is working fine, all templates are made correctly. But (there is always a but), now it creates templates for all the sheets not only the active sheet. You see every sheet will have its own button to create the template. How can this will be done? I know that you must be tired, correcting things, but this will be the last one (I hope...)

Save Created sheet with different name

Participate now!

Share