[VBA] How to split data into multiple workbooks & retain the format

[zeromax1]

Hello everyone. I would like to ask for your help. I want to split the data into multiple workbooks by PIC. (please see the following cap screen) It means each file contains the unique data of each PIC. The format also will be kept for each new workbook. The new workbook name will be the "origin file name - (PIC)" and place at the same path of the origin file.

Besides that, the whole page of "Code Table" will be copy to these new workbook at the same time.

Please download my demo: Trail Split Sheet2.xlsx

The format should be kept in each new workbook. "

I have already refer to this post (VBA Split One Worksheet Into Multiple Workbooks and Retain Formatting) and try to modify the code by myself. Unfortunately, the code only applicable to the Column A with number.

 

[Fluff]

and try to modify the code by myself

Can you post your modified code?

 

[zeromax1]

Can you post your modified code?

Please have a look

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
  
   Set Ws = Sheets("2020 March Master")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("C5", Ws.Range("C" & Rows.Count).End(xlUp))
         If Not .exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.copy
            Range("c4").AutoFilter 1, "<>" & cl.Value
            Range("C5:C200").SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Trial Split Sheet2 " & cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

 

[Fluff]

Thanks for that, you're not far off. It should be

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
  
   Set Ws = Sheets("2020 March Master")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("C6", Ws.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.Copy
            Range("A5").AutoFilter 3, "<>" & cl.Value
            Range("C5:C200").SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Trial Split Sheet2 " & cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

 

[zeromax1]

Thanks for that, you're not far off. It should be

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
 
   Set Ws = Sheets("2020 March Master")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("C6", Ws.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.Copy
            Range("A5").AutoFilter 3, "<>" & cl.Value
            Range("C5:C200").SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Trial Split Sheet2 " & cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

It works, but the title of the column (Row 5) is missing.

The original:

The split file:

On the other hands, I would like to copy sheet2 from the same origin file into the split workbook. Is there any method for that?

 

[zeromax1]

It works, but the title of the column (Row 5) is missing.

The original:
View attachment 9632

The split file:
View attachment 9631

On the other hands, I would like to copy sheet2 from the same origin file into the split workbook. Is there any method for that?

I change the C5 to C6 in the following code and paste all the data into a new workbook as value. It seems work now. But there are some many filter in the top.

Range("C6:C200").SpecialCells(xlVisible).EntireRow.Delete

 

[Fluff]

Did you change this line?

            Range("A5").AutoFilter 3, "<>" & cl.Value

 

[zeromax1]

I change the C5 to C6 in the following code and paste all the data into a new workbook as value. It seems work now. But there are some many filter in the top.

Range("C6:C200").SpecialCells(xlVisible).EntireRow.Delete

View attachment 9636

I don't know why, when I copy all the data and figure into the new worksheet as value, it seems no matter now. And I am curiosity that how to copy the another worksheet at the same time to these new workbook? It means there are 2 worksheets on the origin file like "Master" & "code". I can split the worksheet by PIC in the "Master" worksheet, but I want to copy the "code"sheet" to these new workbook at the same time.

Many thanks, you are awesome.

 

[zeromax1]

Hi Fluff, may I know what's the meaning of 51 in the following code sentence?

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & filename & " " & "(" & cl.Value & ")" & ".xlsx", 51

Did you change this line?

            Range("A5").AutoFilter 3, "<>" & cl.Value

 

[Fluff]

It's the fileformat number specifying to save as an xlsx file.