Solved: Copy rows to 2 different workbooks

[austenr]

I have a master workbook with 12 sheets. I need to split the rows into two workbooks based on an entry in column H. If there is no entry in column H, then it goes in workbook1, if there is an entry in column H, it goes in workbook2. I need to loop through each sheet in the master workbook and copy the rows to the correct workbook. I know how to loop through the master workbook and its sheets but am not sure on how to split out the rows correctly. Thanks for any ideas.

[Charlize]

Do you need to keep the workbook from which you start are may you change it. I mean that when column H is filled in, you move the row to the new workbook that has the same number of worksheets as the original. The original workbook is the one with nothing in column H.

Charlize

[XLGibbs]

Do you need to split all 12 sheets in two depending on the presence of an entry in column H?

And do you mean only two rows per sheet in the master workbook?

[austenr]

Hi Pete and Charlize,

I need to keep the master workbook as is. What I am trying to do is split the master into two worksheets in the destination workbook. This is eventually going to be two pricing tables in access.

So, loop through all worksheets in the master workbook and if there is no entry in column H, copy that row to sheet1 in the new workbook, else copy it to sheet 2 in the new workbook. HTH and thanks

[XLGibbs]

Piece of cake



Sub ccc()
Dim wbMast as workbook, wbDest as workbook
Dim ws1 as worksheet, ws2 as worksheet
Dim c as range, rngLook as range,rngDest1 as Range
Dim rngDest2 as Range, c1 as long, c2 as long
Application.Screenupdating = False

Set wbMast = Workbooks("Master.xls")
Set wbDest = Workbooks("Destination.xls")


Set ws1 = wbDest.Sheets("Sheet1")
Set ws2 = wbDest.Sheets("Sheet2")

set rngDest1 = ws1.Range("A2") 'top left cell of 1st row to recieve data
Set rngDest2 = ws2.Range("A2") 'top left cell of 1st row to recieve data
c2 = 0 'incremental counter to designate offset from that 1st row
c1 = 0
For each ws in wbMast.Worksheets
With ws
Set rngLook = .Range(.cells(1,8),.cells(rows.count,8).end(xlup))
For each c in rngLook
If IsEmpty(c) then
ws2.rngDest1.Offset(c2).EntireRow.Value = c.EntireRow.Value
c2 = c2+1 'increment the offset counter for each new row
Else
ws2.rngDest1.Offset(c2).EntireRow.Value = c.EntireRow.Value
c1= c1+1
End if
Next c
Set rngLook = nothing
Next ws
End with
Application.ScreenUpdating = True
End sub


Written on the fly, might need some tweeking.

[mdmackillop]

Hi Austen,
How many rows are you working with? On a large project, a Filter solution might be a lot quicker
Regards
MD

[XLGibbs]

Hi Austen,
How many rows are you working with? On a large project, a Filter solution might be a lot quicker
Regards
MD
Doh! Good point. Filter column H for non blank> Copy visible cells to sheet 1, second filter. Filter column H for blanks, copy visible cells to sheet 2.

Sub ttt()
Dim wbMast As Workbook, wbDest As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range, rngLook As Range, rngDest1 As Range
Dim rngDest2 As Range, c1 As Long, c2 As Long, ws As Worksheet
Application.ScreenUpdating = False

Set wbMast = Workbooks("Master.xls")
Set wbDest = Workbooks("Destination.xls")

Set ws1 = wbDest.Sheets("Sheet1")
Set ws2 = wbDest.Sheets("Sheet2")


For Each ws In wbMast.Worksheets
With ws
.Cells.AutoFilter Field:=8, Criteria1:="="
.SpecialCells(xlCellTypeVisible).Copy
ws2.Range(Cells(Rows.Count, 1).End(xlUp)).Offset(1).PasteSpecial xlPasteAll

.Cells.AutoFilter Field:=8, Criteria1:="<>"
.SpecialCells(xlCellTypeVisible).Copy
ws1.Range(Cells(Rows.Count, 1).End(xlUp)).Offset(1).PasteSpecial xlPasteAll
End With
Next ws
End With
Application.ScreenUpdating = True
End Sub

Not sure if my syntax is exactly right, but this might work faster..

[austenr]

Thanks Pete. I used the second version. As always great job everyone. Solved.

Malcomb, under 10000 rows.

[XLGibbs]

Thanks Pete. I used the second version. As always great job everyone. Solved.

Malcomb, under 10000 rows.

Second version worked? I am getting better at this I think...wasn't sure if it would work right.

Happy to help. had MD not mentioned it, I would have forgotten about auto filter so the change to my original was pretty simple.

[austenr]

Boy, just when you think you have it, you find a problem. All of the columns are not identical on each sheet. Therefore I can't use your code Pete. I might import each sheet as a table in Access and deal with it there. Is there a way to combine the tables even if the columns are not identical?

[XLGibbs]

What do you mean "not identical"

Do they contain different data all together?

[austenr]

The columns are not in the same order.

[mdmackillop]

I was aware that Austen uses some pretty big spreadsheets, hence the suggestion.

Austen,
Can you post a workbook showing the column arrangenents with a couple of rows of data?

[austenr]

I can post the column Headings. The problem I have is that say you have columns A,B,C,D in the first sheet. In the second sheet, you have a column in the middle of those that are not on sheet1. Let's call it E. So on the second sheet you have A,B,E,C,D. Now column E is totally unique from what is on sheet1. So if you do a straight copy from sheet2 to the new sheet the data will not be under the correct heading when you go to paste sheet2.

[austenr]

Here are the headings from the first few files. The only other thing I can think to do is somehow check the column Headings before you paste the data.

[mdmackillop]

We can as easily a copy/paste in two (or more) parts if that's all that is required, so please post your headings

[austenr]

Ok give me a few

[austenr]

Here ya go.

[mdmackillop]

A further thought. Are the two sheets always going to be consistent for every workbook?

[austenr]

The headings I sent you are from the workbook I want to copy to a new workbook and before you paste the row determine if it has an entry in Col H. If it does it goes on sheet2 of the new workbook. And of course, if not it goes on sheet 1. The columns I gave you will always be presented to me in the master book in that format. Does that answer your question?

[mdmackillop]

Hi Austen
Try this code. Because of the multiple steps involved in this, and the possibilities of changes in presentration of source data. I think you need to contrive a checking mechanism to ensure that totals of both workbooks are consistent.
Option Explicit
Sub ttt()
Dim wbMast As Workbook, wbDest As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, sh As Worksheet
Dim cel As Range, Heading As String
Dim Cols As Long, SourceRw As Long, Rws As Long
Dim c As Range, rngLook As Range, rngDest1 As Range
Dim rngDest2 As Range, c1 As Long, c2 As Long, ws As Worksheet
Dim a, d, e, i 'Create some variables

Application.ScreenUpdating = False

Set wbMast = ActiveWorkbook
Set wbDest = Workbooks("Destination.xls")

Set ws1 = wbDest.Sheets("Sheet1")
Set ws2 = wbDest.Sheets("Sheet2")


'Collect all the column headings
Set d = CreateObject("Scripting.Dictionary")
For Each sh In Sheets
On Error Resume Next
For Each cel In sh.Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
On Error Resume Next
d.Add cel.Text, cel.Text
Next cel
Next sh

'Write unique colum headings to worksheet
a = d.Items 'Get the items
ws1.Activate
For i = 0 To d.Count - 1 'Iterate the array
Cells(1, i + 1) = a(i) 'Print item
Next

'Sort PriceList headings
ws1.Range(Cells(1, 9), Cells(1, Columns.Count).End(xlToLeft) - 4).Sort Key1:=Range("J1"), _
Order1:=xlAscending, Header:=xlNone, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
'Copy sorted headings to second sheet
ws1.Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft)).Copy ws2.Cells(1, 1)

wbMast.Activate
For Each ws In wbMast.Worksheets
SourceRw = ws.Cells(Rows.Count, 1).End(xlUp).Row
'For column H = Blank
With ws
Cols = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
Rws = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1

.Cells.AutoFilter Field:=8, Criteria1:="="
'copy first nine columns
Range(.Cells(2, 1), .Cells(SourceRw, 9)).Copy
ws2.Cells(Rws, 1).PasteSpecial xlPasteAll
'copy last five columns
Range(.Cells(2, Cols - 4), .Cells(SourceRw, Cols)).Copy
ws2.Cells(Rws, Cols - 4).PasteSpecial xlPasteAll
'Check PriceList columns
For i = 10 To Cols - 5
Heading = .Cells(1, i)
Set c = ws2.Rows(1).Find(Heading)
ws.Range(Cells(2, i), Cells(SourceRw, i)).Copy
c.Offset(Rws - 1).PasteSpecial xlPasteAll
Next

'For column H <> Blank
.Cells.AutoFilter Field:=8, Criteria1:="<>"
'copy first nine columns
Range(.Cells(2, 1), .Cells(SourceRw, 9)).Copy
ws1.Cells(Rws, 1).PasteSpecial xlPasteAll
'copy last five columns
Range(.Cells(2, Cols - 4), .Cells(SourceRw, Cols)).Copy
ws1.Cells(Rws, Cols - 4).PasteSpecial xlPasteAll
'Check PriceList columns
For i = 10 To Cols - 5
Heading = .Cells(1, i)
Set c = ws1.Rows(1).Find(Heading)
ws.Range(Cells(2, i), Cells(SourceRw, i)).Copy
c.Offset(Rws - 1).PasteSpecial xlPasteAll
Next
End With
Next ws

Application.ScreenUpdating = True
End Sub

[austenr]

Thank you my friend. I will give it a go and report back. Thanks for taking the time.