VBA Code to Add Worksheet to Workbooks that Split

kamccar

New Member
Joined
Jul 23, 2019
Messages
18
Hi!

I have a code that splits a workbook into multiple workbooks based on unique values in the first column found in Sheet1, however I just want it to also pull the second sheet (Sheet2) that is within the original workbook into all of the workbooks that split.

Any help would be greatly appreciated, the code can be found below. Thank you! :
Sub CreateWorkbooks()

Application.ScreenUpdating = False
Dim LastRow As Long, super As Range, RngList As Object, item As Variant, srcWB As Workbook, srcWS As Worksheet
Set srcWB = ThisWorkbook
Set srcWS = srcWB.Sheets("Sheet1")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set RngList = CreateObject("Scripting.Dictionary")
With srcWS
For Each Rng In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If Not RngList.Exists(Rng.Value) Then
RngList.Add Rng.Value, Nothing
End If
Next
End With
For Each item In RngList
srcWS.Copy
With Cells(1).CurrentRegion
.AutoFilter 1, "<>" & item
ActiveSheet.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
ActiveWorkbook.SaveAs Filename:=srcWB.Path & Application.PathSeparator & item & ".xlsx", FileFormat:=51
ActiveWorkbook.Close False
End With
Next item
Application.ScreenUpdating = True

End Sub
 

Some videos you may like

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,835
Office Version
365
Platform
Windows
How about
Code:
   For Each item In RngList
      Sheets(Array(srcWS, "Sheet2")).Copy
      With Sheets("Sheet1")
         .Cells(1).CurrentRegion.AutoFilter 1, "<>" & item
         .AutoFilter.Range.Offset(1, 0).EntireRow.Delete
         If .AutoFilterMode Then .AutoFilterMode = False
         ActiveWorkbook.SaveAs FileName:=srcWB.Path & Application.PathSeparator & item & ".xlsx", FileFormat:=51
         ActiveWorkbook.Close False
      End With
   Next item
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,835
Office Version
365
Platform
Windows
Which line gave the error?
 

kamccar

New Member
Joined
Jul 23, 2019
Messages
18
Sorry, the Sheets(Array(srcWS, "Sheet2")).Copy gave the mismatch error.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,835
Office Version
365
Platform
Windows
Oops, it should be
Code:
[COLOR=#333333]     Sheets(Array(srcWS[/COLOR][COLOR=#ff0000].Name[/COLOR][COLOR=#333333], "Sheet2")).Copy[/COLOR]
 

kamccar

New Member
Joined
Jul 23, 2019
Messages
18
I put that in, now where it says "For Each item In RngList" it highlights the "For Each Item" as a compile error and says "for control variable already in use"
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,835
Office Version
365
Platform
Windows
You need to replace this part of your code
Code:
[COLOR=#333333]For Each item In RngList[/COLOR]
[COLOR=#333333]srcWS.Copy[/COLOR]
[COLOR=#333333]With Cells(1).CurrentRegion[/COLOR]
[COLOR=#333333].AutoFilter 1, "<>" & item[/COLOR]
[COLOR=#333333]ActiveSheet.AutoFilter.Range.Offset(1, 0).EntireRow.Delete[/COLOR]
[COLOR=#333333]If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False[/COLOR]
[COLOR=#333333]ActiveWorkbook.SaveAs Filename:=srcWB.Path & Application.PathSeparator & item & ".xlsx", FileFormat:=51[/COLOR]
[COLOR=#333333]ActiveWorkbook.Close False[/COLOR]
[COLOR=#333333]End With[/COLOR]
[COLOR=#333333]Next item[/COLOR]
with the code I supplied.
 

kamccar

New Member
Joined
Jul 23, 2019
Messages
18
That worked, thank you so much for all of your help, I really appreciate it!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,835
Office Version
365
Platform
Windows
You're welcome & thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,102,678
Messages
5,488,223
Members
407,632
Latest member
varunwalla

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top