Export store list to new workbook

[Justin Larson]

Alright. To say I'm new to VBA would be an understatement, so my code below
is undoubtedly full of things that don't even make sense. bare with me here.

Here's the situation - I need to take a workbook with a bunch of sheets with
retailer data and export it to a single retail list in a new workbook.

Every sheet with retail data is formatted identically, so that I know that
cells B2:R2 contain the same headers and the data below them contain the same
types of data. The length of lists on each worksheet is different, and
changes every now and then.

I originally recorded a macro that simply selected each sheet by name and
collected the data and dumped it into a new workbook. As time goes on, I'm
getting tired of updating the macro each time I create a new sheet with new
retailers on it, so I need to get some VBA in that is a little more
sophisticated - what I visualize is as follows, I just don't know VBA syntax
well enough to make it work.

The first sheet is always called "Notes on this Document", then there are a
bunch of sheets with retailer information, then a sheet called "bulk", which
is formatted differently than the retailer sheets.

I want the VBA to do this:

Create a new workbook,
find the worksheet called "Notes on this document" and activate the next
sheet.
Copy the headers (B2:R2) from this sheet to the new workbook in A1.
Go back to active worksheet on the original workbook and select B3:R3 and
simulate keystroke CTRL+SHIFT+downarrow (this is the simplist way I could
think of to select the whole list not knowing how big it is).
Copy selected range, insert-paste data into A2 of new workbook - this pushes
all the old data down, and you can repeat it as many times as you want
without having to keep track of what else has been pasted.
go back to retailer workbook and go to next worksheet from active worksheet.
Test the name of active worksheet - if it is called "Bulk", go back to new
workbook sort it (details in code below) and then stop.
If it is not called bulk, repeat the copy paste function listed above,
inserting data below A1 of the new workbook, pushing any existing data
downward.

This way, it doesn't matter how many retailer sheets I have, it will just go
to the next one until it finds "bulk", then stops.

The last thing it should do, after it sees "bulk" is sort the new list.

As a side issue, it would be nice if I could identify the new workbook
somehow renaming it, but not saving it to disk. Right now, this button only
works once, then I have to close excel and reopen it to have it work again,
because my VBA switches between the workbooks by looking for "Book1". Not a
big deal, since I'm usually only exporting once in any given session, but it
would be a nice bonus.

Here's the code I've got, which successfully exports the first sheet, but I
don't know how the syntax of an if/then statement well enough to have it test
the next sheet and choose to repeat or go to next step (sort book1 then end).
the following code is a mix of recorded macro, what I've manually typed in
from notes on this page, and a healthy mix of me not knowing what I'm doing.

All comments welcome. Thanks for your time.



Sub Export_storelist()
'
' Export_storelist Macro
' Macro recorded 11/10/2008 by Justin Larson
'

'
Windows("CAL 2009 Sales Tracker.xls").Activate
Sheets("Notes on this Document").Select
ActiveSheet.Next.Select
Range("B2:R2").Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Add
Range("A1").Select
ActiveSheet.Paste

Windows("CAL 2009 Sales Tracker.xls").Activate
ActiveSheet.Select
Range("B3:R3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Book1").Activate
ActiveWindow.WindowState = xlNormal
ActiveWindow.WindowState = xlNormal
Range("A2").Select
Selection.Insert Shift:=xlDown

Windows("CAL 2009 Sales Tracker.xls").Activate
ActiveSheet.Next.Select
Dim sheet As Worksheet
For Each sheet In Worksheets
If ActiveSheet.Name = "Bulk" Then
End If
Next

Windows("Book1").Activate
ActiveWindow.WindowState = xlNormal
ActiveWindow.WindowState = xlNormal
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1:Q1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
End Sub

 

[Ron de Bruin]

Hi Justin

Start here
http://www.rondebruin.nl/copy2.htm

Read also the tips so you can exclude sheets
It is easy to change it so it copy to a new workbook

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Justin Larson]

This is a very good starting point. Thanks for the pointer. I will work on
adapting this over the next few days and post here if I run into any snags.

Appreciate it.

 

[Ron de Bruin]

I will work on

adapting this over the next few days and post here if I run into any snags.

Ok, post back if you need more help



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Justin Larson]

Alright, had a chance to give this a try before heading home today. It was
actually quite easy to adapt.

there are two things that need to happen for me to be the happiest clam. I
used the example 2 module from your workbook. this module uses some user
defined formulas that find the last row and last column to copy. (below)

the problem is that I don't want to find the last row or last column of each
sheet, only the data directly under the headers in B2:R2. there is data below
the list in B:R, but it's separated by a large space of empty rows. There is
also tons of data farther off to the right of R, but it's all sales data, I
don't want it to be in the merge. I just need to collect store information in
B:R, not the whole sheet.

The second thing is minor, and I'm sure I could come up with a way, but
yours may be cleaner. The headers from all the sheets are the same, so I want
the set of headers to first be pasted into A1:Q1 and all the following data
to be pasted under it. Your module takes the data, but ignores the headers. I
will need to paste the headers, but only the first time, so there is an
identical set at the top.

Make sense?


'Common Functions required for all routines:

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(what:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column

 

[Ron de Bruin]

Hi Justin

For the header row you can find example code above the macro "CopyDataWithoutHeaders"

We can test how big the block of cells is in a column that always have data
Is there a column that always have data ?

Or

there is data below
the list in B:R, but it's separated by a large space of empty rows.

Do you know where this block of data start ?


I will change the code for you if you tell me which column we can test or where
the second data block start



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Justin Larson]

Thanks for your help on this, Ron.

I don't see the sample code you are referring to for the header. I see notes
on selecting a different starting row, but effectively, I want to start at
row two for the first sheet (to include headers) and start at row 3 for all
the following sheets (to exclude headers.

Meanwhile, the data at the bottom of the page is always always in the same
place, but the length of the list may change. So the number of empty cells
between the two may change.

The code needs to start looking in B2 (Header) or B3 (first record) and go
down until it finds a blank, then stop. The width should be fixed at B:R,
because a bunch of sales data exists off to the right, but I don't want that
part included in the merge.

 

[Ron de Bruin]

From the webpage

If you want to copy the header row in the first row of the RDBMergeSheet
then copy the code below if each worksheet have the same headers after
this line : If sh.Name <> DestSh.Name Then

'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A1:Z1").Copy DestSh.Range("A1")
End If

Meanwhile, the data at the bottom of the page is always always in the same
place,

Let me know where the data at the bottom start
We let the code look from there up till the first cell with data

I post a example for you this evening
Must go know



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Justin Larson]

Row 280 on every retail sheet.

Thanks.

From the webpage

If you want to copy the header row in the first row of the RDBMergeSheet
then copy the code below if each worksheet have the same headers after
this line : If sh.Name <> DestSh.Name Then

'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A1:Z1").Copy DestSh.Range("A1")
End If



Let me know where the data at the bottom start
We let the code look from there up till the first cell with data

I post a example for you this evening
Must go know

 

[Ron de Bruin]

Ok I test the macro below in the example workbook from my site(replace the macro in the workbook with this one)
It will also copy the header row

It test the last cell with data now on the sheet with this
shLast = sh.Cells(248, "B").End(xlUp).Row

I set the range like this now
Set CopyRng = sh.Range("B" & StartRow & ":R" & shLast)


Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

'Fill in the start row
StartRow = 2

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets

'Loop through all worksheets except the RDBMerge worksheet and the
'Information worksheet, you can ad more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Information"), 0)) Then

'Copy header row
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("B1:R1").Copy DestSh.Range("A1")
End If

'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = sh.Cells(248, "B").End(xlUp).Row


'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then

'Set the range that you want to copy
Set CopyRng = sh.Range("B" & StartRow & ":R" & shLast)

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If

End If
Next

ExitTheSub:

Application.GoTo DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Justin Larson]

YOU JUST MADE MY DAY. Works like a charm.

In case you care, here's the final working code in context of my sheet.

Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RetailMerge" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RetailMerge").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RetailMerge"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RetailMerge"

'Fill in the start row
StartRow = 3

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets

'Loop through all worksheets except the RetailMerge worksheet and the
'sheets at the end, you can ad more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Notes on this
Document", "bulk", "SKU Information", "Participating Utilities"), 0)) Then

'Copy header row
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("B2:R2").Copy DestSh.Range("A1")
End If

'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = sh.Cells(248, "B").End(xlUp).Row


'If sh is not empty and if the last row >= StartRow copy the
CopyRng
If shLast > 0 And shLast >= StartRow Then

'Set the range that you want to copy
Set CopyRng = sh.Range("B" & StartRow & ":R" & shLast)

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to
copy the
'values or want to copy everything look below example 1 on
this page
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If

End If
Next

ExitTheSub:

Application.GoTo DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Ron de Bruin]

You are welcome

Have a nice weekend

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm