VBA code - Create New Workbook for each cell value and then name each new work book with 2 cell values

DharmaK

New Member
Joined
Jul 28, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hi Guys, I hope I might get some help in this form in regards to what i am trying to achieve, Create New Workbook for each cell value and then name each new work book with 2 cell values.
So on the below code it does the job of creating new work book from each cell, but i would like to name the new work book automatically with a the cell name used to split the work book.
Any help in here is appreciated.
Sub CopyInNewWB()


Dim wbO As Workbook, wbN As Workbook
Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Dim xCName As Integer
Dim xTA, xRA, xSRg1 As String
Set xSht = ThisWorkbook.Worksheets("Template")

On Error Resume Next

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False




xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row

xTitle = "A:K"

xCName = "2" 'Change this number to the column number which you will create new sheets based on

xTRrow = xSht.Range(xTitle).Cells(1).Row

For I = 2 To xRCount
Call xCol.Add(xSht.Cells(I, xCName).Text, xSht.Cells(I, xCName).Text)

Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
xSRg = xSht.Cells(1, xCName).Address(RowAbsolute:=False, ColumnAbsolute:=False)

For I = 1 To xCol.Count
Set wbN = Workbooks.Add

ThisWorkbook.Sheets("CoverPage").Copy After:=Sheets(Sheets.Count)
Call xSht.Range(xTitle).AutoFilter(xCName, CStr(xCol.Item(I)))

Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
wbN.Sheets("Sheet1").Delete
xNSht.Name = CStr(xCol.Item(I))
ActiveWindow.DisplayGridlines = False


Else

xNSht.Move , Sheets(Sheets.Count)




End If



xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
With ActiveWorkbook
For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks)
.BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks

Next
End With
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate

Sheets("ReportH").Activate
Call Sheets("ReportH").ForceClickOnBouttonXYZ
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True


End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,747
Office Version
  1. 2007
Platform
  1. Windows
Hi and welcome to MrExcel.

I made some improvements to the code and simplified it a bit.

Create New Workbook for each cell value and then name each new work book with 2 cell values.
One cell is the one in column 2, but what is the other cell?

I'm not sure if this should go for every new book as it is out of the For.
VBA Code:
  With ActiveWorkbook
    For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks)
      .BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks
    Next
  End With

Try the following to save the book in the same folder:

VBA Code:
Sub CopyInNewWB_2()
  Dim wbN As Workbook
  Dim xSht As Worksheet, xNSht As Worksheet
  Dim i As Long, xCName As Long
  Dim dic As Object, ky As Variant, lnk As Variant
  Dim xTitle As String
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False
  
  Set xSht = ThisWorkbook.Sheets("Template")
  Set dic = CreateObject("Scripting.Dictionary")
  
  xCName = "2" 'Change this number to the column number which you will create new sheets based on
  xTitle = "A:K"
  
  For i = 2 To xSht.Cells(Rows.Count, xCName).End(xlUp).Row
    dic(xSht.Cells(i, xCName).Value) = Empty
  Next
  
  For Each ky In dic.keys
    ThisWorkbook.Sheets("CoverPage").Copy
    Set wbN = ActiveWorkbook
    xSht.Range(xTitle).AutoFilter xCName, ky
    Set xNSht = Worksheets.Add(, wbN.Sheets(wbN.Sheets.Count))
    xNSht.Name = ky
    ActiveWindow.DisplayGridlines = False
    xSht.AutoFilter.Range.EntireRow.Copy xNSht.Range("A1")
    xNSht.Columns.AutoFit
    
    'save workbook
    wbN.SaveAs ThisWorkbook.Path & "\" & ky
    wbN.Close False
  Next
  
  On Error Resume Next
  With ActiveWorkbook
    For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks)
      .BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks
    Next
  End With
  On Error GoTo 0
  xSht.AutoFilterMode = False
  
  Sheets("ReportH").Activate
  Call Sheets("ReportH").ForceClickOnBouttonXYZ
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.DisplayAlerts = True
End Sub
 

DharmaK

New Member
Joined
Jul 28, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hi Amor, Thank you for the quick reply.
I did try the code but i am getting the below error and the name i would like to achieve for the workbook is Column A " - " Column B.xlsx (Should look like this Account code - Cost Centre.xlsx )
1627520396725.png

1627520522061.png
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,747
Office Version
  1. 2007
Platform
  1. Windows
You can check, at the time of the error, what value the variable ky has. You can put the mouse over the variable ky in the error line and a window should appear with the data.

Maybe you have cells with empty in the range of column B, also check your data.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,747
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

the name i would like to achieve for the workbook is Column A " - " Column B.xlsx
Try this:

VBA Code:
Sub CopyInNewWB_2()
  Dim wbN As Workbook
  Dim xSht As Worksheet, xNSht As Worksheet
  Dim i As Long, xCName As Long
  Dim dic As Object, ky As Variant, lnk As Variant
  Dim xTitle As String
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False
  
  Set xSht = ThisWorkbook.Sheets("Template")
  Set dic = CreateObject("Scripting.Dictionary")
  
  xCName = 2 'Change this number to the column number which you will create new sheets based on
  xTitle = "A:K"
  
  For i = 2 To xSht.Cells(Rows.Count, xCName).End(xlUp).Row
    If xSht.Cells(i, xCName).Value <> "" Then dic(xSht.Cells(i, xCName).Value) = xSht.Cells(i, "A").Value
  Next
  
  For Each ky In dic.keys
    ThisWorkbook.Sheets("CoverPage").Copy
    Set wbN = ActiveWorkbook
    xSht.Range(xTitle).AutoFilter xCName, ky
    Set xNSht = Worksheets.Add(, wbN.Sheets(wbN.Sheets.Count))
    xNSht.Name = ky
    ActiveWindow.DisplayGridlines = False
    xSht.AutoFilter.Range.EntireRow.Copy xNSht.Range("A1")
    xNSht.Columns.AutoFit
    
    'save workbook
    wbN.SaveAs ThisWorkbook.Path & "\" & dic(ky) & " - " & ky
    wbN.Close False
  Next
  
  On Error Resume Next
  With ActiveWorkbook
    For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks)
      .BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks
    Next
  End With
  On Error GoTo 0
  xSht.AutoFilterMode = False
  
  Sheets("ReportH").Activate
  Call Sheets("ReportH").ForceClickOnBouttonXYZ
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.DisplayAlerts = True
End Sub
 
Solution

DharmaK

New Member
Joined
Jul 28, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
You are right there are some blanks in the Column A and Column B at the end of the data, but is it possible to have code to ignore the blanks and just run on Column A and Column B values
 

DharmaK

New Member
Joined
Jul 28, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

This time i am getting the error in here,
1627521827271.png
 

DharmaK

New Member
Joined
Jul 28, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
This is the code to activate the button to run the vb code form excel,
'Name macro
Sub CopySheetsToNewWorkbooks()

'Dimension variable and declare data types
Dim SHT As Worksheet

'Iterate through worksheets in active workbook


'Copy worksheet to a new workbook
ThisWorkbook.Sheets("ReportH").Copy

'Continue with next worksheet in acteive workbook


'Stop macro
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,747
Office Version
  1. 2007
Platform
  1. Windows
Sheets("ReportH").Activate
at that point the macro is finished, and all the files are already created. that line of code is from your macro. If you don't need it, you can delete it.
 

DharmaK

New Member
Joined
Jul 28, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Excellent Amor you are a Legend, I took those debug lines it worked like charm.
Just another question, by default its savings to my desktop, is there as way that it doesn't save to desktop but just open the instances on the screen?
 

Forum statistics

Threads
1,143,661
Messages
5,720,145
Members
422,267
Latest member
olund

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top