VBA to separate three tabs form master and paste existing data's in it as "values" (no link to master when separated)

[nscaria00]

Good Morning,
I have a master excel document which has couple of tabs (shown in tabs to extract image). I am populating data's in three tabs (component, tools and logistics) from other tabs by using "=" function. But I need to extract these three documents before I send to customer.
I am looking for a VBA code to extract these three tabs from master and create another document (with these three tabs) and save with RFQ number from "Pre-review checklist" B1 cell.
In the extracted files, "=" function should not be there and the datas needs to show as values (i mean not linked any more to master file). Is it doable?
I can share the excel document if needs to.
Thanks,

 

[dreid1011]

This may do what you want. It looks like you want the code to run when you click a button, so the code event should look something like this:

Sub NameOfButton_Click()

Replace "NameOfButton" with your button name, assuming it is a command button. If it is a form button, then assign the following vba code to it:

Sub CopySheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim wbNewPath As String
Dim shNew As Worksheet
Dim arSh() As Variant
Dim i As Long

Set wb = Workbooks("Book1 3-1-2024.xlsm")

wbNewPath = ThisWorkbook.Path & "\" & Sheets("Pre-review Checklist").Range("B1").Value & ".xlsx"

Set wbNew = Workbooks.Add

arSh = Array("Component", "Tools", "Logistics")

On Error Resume Next

For i = 0 To 2
    wb.Sheets(arSh(i)).Cells.Copy
    
    With wbNew.Worksheets

          Set shNew = Nothing
          Set shNew = .Item(arSh(i))

          If shNew Is Nothing Then
              .Add After:=.Item(.Count)
              .Item(.Count).Name = arSh(i)
              Set shNew = .Item(.Count)
          End If
      End With

      With shNew.Range("A1")
          .PasteSpecial (xlPasteColumnWidths)
          .PasteSpecial (xlFormats)
          .PasteSpecial (xlValues)
          .Select
      End With
Next i

Application.DisplayAlerts = False
wbNew.Sheets("Sheet1").Delete
wbNew.SaveAs wbNewPath
wbNew.Close
Application.DisplayAlerts = True

End Sub

 

[nscaria00]

It does extracted and saved as per requirement. But no datas - nothing. It's empty. Only colors are there per original document.
Please see attachment.

 

[dreid1011]

It does extracted and saved as per requirement. But no datas - nothing. It's empty. Only colors are there per original document.
Please see attachment.

Interesting. It is pasting values for me when I test.. Not sure what else to try but I'll let you know if I come up with something different.

 

[dreid1011]

Here it is again with some very minor changes.

Sub CopySheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim wbNewPath As String
Dim shNew As Worksheet
Dim arSh() As Variant
Dim i As Long

Set wb = Workbooks("Book1 3-1-2024.xlsm")

wbNewPath = ThisWorkbook.Path & "\" & Sheets("Pre-review Checklist").Range("B1").Value & ".xlsx"

Set wbNew = Workbooks.Add

arSh = Array("Component", "Tools", "Logistics")

On Error Resume Next

For i = 0 To 2
    wb.Sheets(arSh(i)).UsedRange.Copy
    
    With wbNew.Worksheets

          Set shNew = Nothing
          Set shNew = .Item(arSh(i))

          If shNew Is Nothing Then
              .Add After:=.Item(.Count)
              .Item(.Count).Name = arSh(i)
              Set shNew = .Item(.Count)
          End If
      End With

      With shNew.Range("A1")
          .PasteSpecial xlPasteColumnWidths
          .PasteSpecial xlPasteFormats
          .PasteSpecial xlPasteValues
          .Select
      End With
Next i

Application.DisplayAlerts = False
wbNew.Sheets("Sheet1").Delete
wbNew.SaveAs wbNewPath
wbNew.Close
Application.DisplayAlerts = True

End Sub

 

[nscaria00]

Unfortunately same issue. Attached pictures for your reference.

I wish I can send excel file for reference.

 

[dreid1011]

You could upload the book to a file share and post the link.

 

[nscaria00]

Added to wetransfer: Link below:

Trial

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

 

[dreid1011]

Alright, give this a try:

Sub CopySheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim wbNewPath As String
Dim shNew As Worksheet
Dim arSh() As Variant
Dim i As Long

Set wb = Workbooks("Part Master.xlsm")

wbNewPath = ThisWorkbook.Path & "\" & Sheets("Pre Review Checklist").Range("B1").Value & ".xlsx"

Set wbNew = Workbooks.Add

arSh = Array("Component", "Tools", "Logistics")

On Error Resume Next

For i = 0 To 2
    With wbNew.Worksheets

          Set shNew = Nothing
          Set shNew = .item(arSh(i))

          If shNew Is Nothing Then
              .Add After:=.item(.Count)
              .item(.Count).Name = arSh(i)
              Set shNew = .item(.Count)
          End If
      End With
      wb.Sheets(arSh(i)).UsedRange.Copy
      With shNew.Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteColumnWidths
        .PasteSpecial xlPasteFormats
        .Select
      End With
Next i

Application.DisplayAlerts = False
wbNew.Sheets("Sheet1").Delete
wbNew.SaveAs wbNewPath
wbNew.Close
Application.DisplayAlerts = True

End Sub

It's not going to copy the image on the "Component" page and the row heights are default. They can be adjusted if you need them to be, but its not as easy as column widths.

 

[nscaria00]

Alright, give this a try:

Sub CopySheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim wbNewPath As String
Dim shNew As Worksheet
Dim arSh() As Variant
Dim i As Long

Set wb = Workbooks("Part Master.xlsm")

wbNewPath = ThisWorkbook.Path & "\" & Sheets("Pre Review Checklist").Range("B1").Value & ".xlsx"

Set wbNew = Workbooks.Add

arSh = Array("Component", "Tools", "Logistics")

On Error Resume Next

For i = 0 To 2
    With wbNew.Worksheets

          Set shNew = Nothing
          Set shNew = .item(arSh(i))

          If shNew Is Nothing Then
              .Add After:=.item(.Count)
              .item(.Count).Name = arSh(i)
              Set shNew = .item(.Count)
          End If
      End With
      wb.Sheets(arSh(i)).UsedRange.Copy
      With shNew.Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteColumnWidths
        .PasteSpecial xlPasteFormats
        .Select
      End With
Next i

Application.DisplayAlerts = False
wbNew.Sheets("Sheet1").Delete
wbNew.SaveAs wbNewPath
wbNew.Close
Application.DisplayAlerts = True

End Sub

It's not going to copy the image on the "Component" page and the row heights are default. They can be adjusted if you need them to be, but its not as easy as column widths.

That works well. Thank you so much. Just one more questions. If I need to keep Customer cells intact (meaning leave the formulas as such in the copied document as well similar to the ones we extracted from), is that possible? All the cells other than white and yellow color are Customer filled formulas. Attached image as example. I am sorry asking this.