Distribute rows from 1 ws into about 100 different workbooks and copy 2 ws to all.

[jtpilgrim]

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

[SamT]

.Copy After:=Workbooks(wbNew).Sheets(1)

wbNew is a Workbook Object, not a name

.Copy After:=wbNew.Sheets(1)

I am using Excel XP, SP3 with excel 2007 Compatibility Pack and I can't find a FileFormat Constant = 56. There is a reason Microsoft provides all those nice descriptive constants. If you are still using *.xls files, you might want to use FileFormat:=FileFormat:=xlWorkbookNormal

A Critique
Option Explicit

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 'Add to which Workbook?

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 'Add to which Workbook?
wsData.Range("A1:BQ" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngCrit.Offset(-1).Resize(2), _
CopyToRange:=wsNew.Range("A1"), Unique:=True

wsNew.Name = rngCrit 'Move to after the Set wsNew
wsNew.Copy 'Not used. No Paste.
Columns.AutoFit 'Which Worksheet?
Set wbNew = ActiveWorkbook 'Which Workbook is Active at this time

Windows("Filename.xls").Activate 'Do you have a workbook named "FileName" open ATT?
Sheets(Array("FieldDesc", "ARC-Codes")).Select
Sheets("ARC-Codes").Activate 'Deselects other Worksheets
Sheets(wsNew.Name).Activate 'DeActivates "Arc-Codes"

Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=Workbooks(wbNew).Sheets(1) 'wbNew is a Workbook Object, not a name

'The Previous 5 lines can be sortened to one line
'Workbooks("Filename.xls").Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=wbNew.Sheets(1)

wbNew.Activate 'The Copy Sheets to Activated this Workbook
'This is where you use ActiveBook.SaveAs and ActiveBook.Close
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

Here is a version I came up with.I couldn't test it, but it does Compile
Option Explicit

Sub DistributeRows()

Dim TempBookName As String
Dim SaveName As String
Dim wsData As Worksheet
Dim FDESC As Worksheet
Dim ARCC As Worksheet
Dim NewBookNames As Variant
Dim LastRow As Long
Dim i As Long

'Uncomment after testing
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
'Application.EnableEvents = False

Set wsData = Worksheets("my data")
Set FDESC = Workbooks("Filename.xls").Sheets("FieldDesc")
Set ARCC = Workbooks("Filename.xls").Sheets("ARC-Codes")

LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row

wsData.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wsData.Columns(Columns.Count - 1).Cells(1), Unique:=True

NewBookNames = Array(wsData.Columns(Columns.Count - 1))
wsData.Columns(Columns.Count - 1).Delete

For i = LBound(NewBookNames) To UBound(NewBookNames)
SaveName = NewBookNames(i) & Format(Date, "-yymmdd") ' & ".xls" ?

ARCC.Copy 'Creats new workbook, which is the Active Book
TempBookName = ActiveWorkbook.Name
FDESC.Copy Workbooks(TempBookName)

With Workbooks(TempBookName)
.Worksheets.Add 'This is the Active sheet
'.ActiveSheet. Name = "???"
End With

'Try it n see, I am fuzzy on this step.
wsData.Range("A1:BQ" & LastRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=NewBookNames(i), _
CopyToRange:=Workbooks(TempBookName).ActiveSheet.Range("A1"), _
Unique:=True 'Can you use The sheet Name instead of "ActiveSheet?"

Workbooks(TempBookName).SaveAs ThisWorkbook.Path & "\BpouFiles\" & SaveName, _
FileFormat:=xlWorkbookNormal '<----- ? ------------------

Windows(SaveName).Close 'Doesn't need, (can't use,) the File Extension
Next i

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

[jtpilgrim]

I don't even know and could not find instructions on how to reply but I am using Excel 2013 on a Windows 7 Pro machine and I am using xls files.

I have attached a copy of a test spreadsheet with some dummy data and a modified Old version of the code, OldWorkingDistrRows(), that works but does not copy the 2 extra worksheets "FieldDesc", "ARC-Codes".

I have also put in the code SamT provided as "DistributeRows" but do not understand that code enough to attempt completing it.

The directory the spreadsheet is in needs a subdirectory named BFiles for the example to work or at least I have always created the sub-directories that I use before I run the code.


[Edit: Deleted Quote of entire previous post. Moderator]

[snb]

Basically this is the only code you need:


Sub M_snb()
sn = Sheet1.Columns(1).SpecialCells(2)

For j = 1 To UBound(sn)
Sheets(Array("sheet2", "sheet3")).Copy
With ActiveWorkbook
.SaveAs "G:\OF\" & sn(j, 1) & "xlsx", 51
.Close 0
End With
Next
End Sub

[SamT]

ActiveWorkbook.Close -1, "G:\OF\" & sn(j, 1) & ".xlsx"

Sheets(Array("sheet2", "sheet3")).Copy
Compiles but raises Copy Method Failed run time error.

[jtpilgrim]

Thank you very much for the help. I have been able to use some of the suggestions and produce a working version.
The major issue was the way I was trying to use wbNew to represent a string because it appeared to be correct in the debug process and the recommended use of:
ThisWorkbook.Sheets(Array("FieldDesc", "ARC-Codes")).Copy After:=wbNew.Sheets(1), to do the copy works great.

[snb]

@SamT


Sheets(Array("sheet2", "sheet3")).Copy
Compiles but raises Copy Method Failed run time error.

No errors here. Time to 'update' ? ;)

[SamT]

@ snb

No doubt, but I'll just have to keep plugging away with my 12 yo computer and second hand copy of Office XP. :banghead:

[snb]

@SamT

Nothing wrong with XP.

Your nice(!) suggestion ActiveWorkbook.Close -1, "G:\OF\" & sn(j, 1) & ".xlsx" errors out on my system.

I think Jacob might offer you some compensation for your moderation work in this forum.