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

[DharmaK]

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

 

[DanteAmor]

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.

  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:

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]

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 )

 

[DanteAmor]

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]

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

Try this:

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

 

[DharmaK]

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]

This time i am getting the error in here,

 

[DharmaK]

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]

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]

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?