jtpilgrim
10-23-2015, 04:02 PM
The Original workbook has a worksheet named "my data" with 1000 to 5000 rows containing data from 100 to 200 categories with the category name in column A.
There are also 2 worksheets named "FieldDesc" and "ARC-Codes" of information data that I want in all of the target workbooks.
I have tried this a dozen different ways and and tried suggestions from many forums and all have failed, almost always with error 9 or 13 with a type
mismatch or subscript out of range in the portion that attempts to Copy the "FieldDesc" and "ARC-Codes" into the wbNew workbook.
The problem seems to be with the way I am creating the new workbook that contains the new worksheet that gets named from the rngCrit variable.
The current version fails with a "Type mismatch on wbNew in this line of code. Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=Workbooks(wbNew).Sheets (1)
If I remove the lines of code that attempt to copy the 2 worksheets "FieldDesc", "ARC-Codes", it works great.
Sub DistributeRows()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set wsData = Worksheets("my data")
Set wsCrit = Worksheets.Add
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
wsData.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add
wsData.Range("A1:BQ" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
wsNew.Name = rngCrit
wsNew.Copy
Columns.AutoFit
Set wbNew = ActiveWorkbook
Windows("Filename.xls").Activate
Sheets(Array("FieldDesc", "ARC-Codes")).Select
Sheets("ARC-Codes").Activate
Sheets(wsNew.Name).Activate
Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=Workbooks(wbNew).Sheets (1)
wbNew.Activate
wbNew.SaveAs ThisWorkbook.Path & "\BpouFiles\" & rngCrit & Format(Now, "-yymmdd"), FileFormat:=56
wbNew.Close SaveChanges:=True
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("A2")
Wend
wsCrit.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
There are also 2 worksheets named "FieldDesc" and "ARC-Codes" of information data that I want in all of the target workbooks.
I have tried this a dozen different ways and and tried suggestions from many forums and all have failed, almost always with error 9 or 13 with a type
mismatch or subscript out of range in the portion that attempts to Copy the "FieldDesc" and "ARC-Codes" into the wbNew workbook.
The problem seems to be with the way I am creating the new workbook that contains the new worksheet that gets named from the rngCrit variable.
The current version fails with a "Type mismatch on wbNew in this line of code. Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=Workbooks(wbNew).Sheets (1)
If I remove the lines of code that attempt to copy the 2 worksheets "FieldDesc", "ARC-Codes", it works great.
Sub DistributeRows()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set wsData = Worksheets("my data")
Set wsCrit = Worksheets.Add
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
wsData.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add
wsData.Range("A1:BQ" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
wsNew.Name = rngCrit
wsNew.Copy
Columns.AutoFit
Set wbNew = ActiveWorkbook
Windows("Filename.xls").Activate
Sheets(Array("FieldDesc", "ARC-Codes")).Select
Sheets("ARC-Codes").Activate
Sheets(wsNew.Name).Activate
Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=Workbooks(wbNew).Sheets (1)
wbNew.Activate
wbNew.SaveAs ThisWorkbook.Path & "\BpouFiles\" & rngCrit & Format(Now, "-yymmdd"), FileFormat:=56
wbNew.Close SaveChanges:=True
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("A2")
Wend
wsCrit.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub