Conditional Copy/Paste

[mjack003]

Hi,

I've been working on a master inventory workbook for the longest time.
Its coming along but I've ran into a snag. The way it is set up is th
first worksheet contains the master list, "Teardown Inventory". Item
are listed in columns A:F rows 6:4500. All other worksheets represen
a box, pallet, or skid and as they are packed items from the maste
inventory are copied to the "container" they are packed in. I've adde
a column G where the user can enter the container type and numer (ex
Box 1). Now what I need to do is create a macro which, when executed
will copy that row from column A:E and paste it into the correspondin
container entered in column G. I've come up witha few generic idea
but none seem to work. I tried list boxes but this takes far too lon
considering there are 4500 parts or so. I also ran into a problem wit
duplicates being pasted into containers everytime the macro was ru
along with any new items. I'm still new to VBA so this is beyond me.
Any help is appreciated.

Best Regards,
Mjac

 

[Dave Peterson]

I'd look at Debra Dalgleish's sample files and try to steal some code from
there:

http://www.contextures.com/excelfiles.html

Look for:

Update Sheets from Master -- uses an Advanced Filter to send data from
Master sheet to individual worksheets -- creates a list of unique items,
creates a sheet for each item, then replaces old data with current.
AdvFilterCity.xls 46 kb

and

Create New Sheets from Filtered List -- uses an Advanced Filter to create
separate sheet of orders for each sales rep visible in a filtered list; macro
automates the filter. AdvFilterRepFiltered.xls 35 kb

 

[mjack003]

Thanks Dave. Those should work great. I should be able to combine the
to create what I need. Thanks again for the help. I'm sure I'll b
back with a few questions

Mjac

 

[mjack003]

Hey Dave,

I've been trying to apply the "Update sheets from masters" to my ow
book but I'm running into some problems. The whole part about definin
names for criteria area loses me. I can't figure out how I would us
column G to create the "city" (in my case boxes) list on the secon
worksheet. And also since my main sheet and city sheets are formatte
differently how I would create lists starting from A1717 on down o
the city sheets while on the main sheet the criteria to be filtered i
from A66. Also since they are different, is there a function whic
could load a template file for each "city" instead of using the header
from the main sheet? This macro contains everything that I need it t
do but I just can't get it to apply to my workbook. I appreciate an
help because this would save me an incredible amount of tim
considering I manually copy/paste about three thousand parts a day


Best Regards,
Mjac

 

[Dave Peterson]

Debra uses some dynamic range names to make her life a little easier.

Here's her code:

Option Explicit

Sub FilterCities()
Dim c As Range
Dim ws As Worksheet

'Add the heading to the criteria area
' and cities extract area
Sheets("CITIES").Range("A1").Value = _
Sheets("MAIN").Range("A1").Value
Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("A1").Value
'rebuild the CityList
Sheets("MAIN").Columns("A:A").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
Unique:=True
Sheets("CITIES").Range("A1").CurrentRegion.Sort _
Key1:=Sheets("CITIES").Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
'Add the heading to the criteria area
Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("A1").Value
'check for individual City worksheets
For Each c In Range("CityList")
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Else
Worksheets(c.Value).Cells.Clear
End If
'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value
'transfer data to individual City worksheets
Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Next
MsgBox "Data has been sent"
End Sub


Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

=======
She has these two lines:
Dim c As Range
....
For Each c In Range("CityList")

And citylist is defined as:
=OFFSET(CITIES!$A$2,0,0,COUNTA(CITIES!$A:$A)-1,1)
This means that it's in the Cities worksheet starting at A2 and going down the
column for as many entries as there are there (but subtracts one for the
header).

Since this is a dynamic range, if you have 12 city names, or 122 city names, the
range will always include all the data.

On a test worksheet, try creating a range in A1:a99, then make a name like
Debra's =offset() formula. Just use the name of that worksheet in place of
cities.

Now hit F5 (edit|goto) and type in Citylist. You'll see all the cells
selected. Now delete a few rows from the bottom (don't leave gaps). Then
edit|goto and type citylist. You'll see that range contracted to just what was
left.

Debra has some nice notes about these dynamic ranges at:
http://www.contextures.com/xlNames01.html#Dynamic
You might be able to see it better.

It turns out that she uses that range to grab each unique value in your original
list. So after you create the name (and match it up in the code), you should be
ok.

And she does something with the name DataBase, too.

=OFFSET(MAIN!$A$1,0,0,COUNTA(MAIN!$A:$A),COUNTA(MAIN!$1:$1))

This one counts the number of columns used (don't leave gaps) and the number of
rows used (no gaps here either).

Then when she shows each value in that cityrange, she can copy it to either a
new workbook (or an existing workbook that's been cleared of all data).

This portion either creates a new worksheet or clears out the existing sheet:
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Else
Worksheets(c.Value).Cells.Clear
End If

Since you want to keep rows 1:16, you could modify that Else portion like:

Worksheets(c.Value).Cells.Clear
becomes
worksheets(c.value).rows("17:65536").clear

later on, you can paste into A17:

Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False

becomes:

Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=Sheets(c.Value).Range("A17"), _
Unique:=False

(A1 changed to A17.)

I'm not sure what criteria to be filtered is A6:d6. I'm guessing that you meant
A6 down (headers in A1:A5?).

Then you'll have to adjust your range name:

=OFFSET(MAIN!$a$5,0,0,COUNTA(MAIN!$A:$A)-5,COUNTA(MAIN!$1:$1))

(A5 to include the header & -5 only if A1:a5 (5 cells) have something in
them--you'll have to adjust that -5 to match your data.)

But since you're changing your headers, you have to change your advanced filter
to match up:

Sheets("CITIES").Range("A1").Value = _
Sheets("MAIN").Range("A5").Value
Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("A5").Value

(It moves the headers into the right spots.)

I didn't test this, but it might be closer--I tried to include all those notes.
After writing most of this, I figured you could have the code define the
citylist name each time it runs--if you define it, that's fine, but the code
ignores your work--actually it destroys it!

So (if this works (haha!)), then all you have to do is define that Database name
correctly--remember no gaps in your rows or columns!

Option Explicit

Sub FilterCities()
Dim c As Range
Dim ws As Worksheet
Dim cityListRange As Range

Sheets("CITIES").Range("A1").Value = _
Sheets("MAIN").Range("A5").Value

Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("A5").Value

'rebuild the CityList
With Sheets("Main")
.Range("a5:a" & .Cells(.Rows.Count, "A").End(xlUp).Row).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
Unique:=True
End With

Set cityListRange = Sheets("CITIES").Range("A1").CurrentRegion
With cityListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "CityList"
End With

'Add the heading to the criteria area
Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("A5").Value

'check for individual City worksheets
For Each c In Range("CityList")
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Worksheets("main").Rows("1:16").Copy _
Destination:=ws.Range("a1")
Else
Worksheets(c.Value).Rows("17:65536").Clear
End If

'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value

'transfer data to individual City worksheets
Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=Sheets(c.Value).Range("A17"), _
Unique:=False
Next
MsgBox "Data has been sent"
End Sub


Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[mjack003]

Wow Dave! I don't know how to thank you That's quite the explanatio
and the surprising part is I'm beginning to actually understand it.
One question though. I haven't had a chance to test this yet but sinc
my "cities" are listed in col. G instead of A, won't that change how
would define "Database". Also, from the looks of it this macro work
from left to right and since they are being split up according t
column G will the macro work right to left, meaning advanced filte
runs in column G and copies from A:F? Thank you again for taking th
time to explain.

Best Regards,
Mjac

 

[Dave Peterson]

Yep. I think you're right (but it was difficult to see without test data!)

I missed changing some of the column A references to G.

And there's another problem. If the worksheet didn't exist, I was copying the
first 16 rows of the Main sheet to be used as headers.

But that's not how your worksheets are laid out. Your data starts in row 6!

If you need 16 rows of header, create a worksheet named "header" and put those
16 rows in there (and that's all).

Then change this line:
Worksheets("main").Rows("1:16").Copy _
Destination:=ws.Range("a1")
to
Worksheets("header").Rows("1:16").Copy _
Destination:=ws.Range("a1")

You could even hide that "header" sheet if you wanted it out of the way.

(Copying from A:G or G:A will do the same -- if I understood your question.)

I created some test data and modified the code. It worked ok--but I ain't
vouching for it working against your data.

I did create a "Header" sheet (seemed reasonable that you'd need it, too!).
Notice that both the DataBase and citylist names are created in code now.

Option Explicit
Sub FilterCities()
Dim c As Range
Dim ws As Worksheet
Dim cityListRange As Range
Dim dummyRng As Range
Dim myDataBase As Range

With Worksheets("MAIN")
Set dummyRng = .UsedRange 'try to reset lastusedcell
Set myDataBase = .Range("a5", .Cells.SpecialCells(xlCellTypeLastCell))
End With
myDataBase.Name = "Database"

'rebuild the CityList
With Sheets("Main")
.Range("g5:g" & .Cells(.Rows.Count, "g").End(xlUp).Row).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
Unique:=True
End With

Set cityListRange = Sheets("CITIES").Range("A1").CurrentRegion
With cityListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "CityList"
End With

Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("g5").Value

'check for individual City worksheets
For Each c In Range("CityList")
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Worksheets("header").Rows("1:16").Copy _
Destination:=ws.Range("a1")
Else
Worksheets(c.Value).Rows("17:65536").Clear
End If

'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value

'transfer data to individual City worksheets
Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=Sheets(c.Value).Range("A17"), _
Unique:=False
Next
MsgBox "Data has been sent"
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[Dave Peterson]

Oops. One more thing.

I think it's better to clear out the "Cities" column A before you do the
extraction. (Thanks, Deb!)

Right before the 'rebuild city list,
add this line:

Worksheets("cities").Columns(1).Clear
'rebuild the CityList

(If you change the header for column G, then it could make the code blow up. If
you let excel do it's thing, then it'll populate A1 with the header.)

 

[Debra Dalgleish]

Thanks for all the changes you suggested, and the excellent explanation
you gave, for how it all works.

Oops. One more thing.

I think it's better to clear out the "Cities" column A before you do the
extraction. (Thanks, Deb!)

Right before the 'rebuild city list,
add this line:

Worksheets("cities").Columns(1).Clear
'rebuild the CityList

(If you change the header for column G, then it could make the code blow up. If
you let excel do it's thing, then it'll populate A1 with the header.)

 

[mjack003]

Hi Dave,

Its beginning to take shape. Its creating four boxes and then stop
looping and saying the data has been sent even though there are stil
six boxes to be sorted. I forgot to mention there are blank spaces i
column G for items which have not been assigned a box yet which i
creating a blank space about half way down the city list. I'm sur
this is where it is getting caught up but is there anyway to bypass th
blank space and continue down the list? On the Cities worksheet D:1 i
populated correctly but D:2 is populated with the data contained in th
cell just above the blank space. Also, is there anyway to populat
G:15 with "c.value" also when it is created? I couldn't figure ou
where to stick it in the loop. Thank you for helping me on this. Wil
be great if we can get it working.

Best Regards,
Mjac

 

[Dave Peterson]

Maybe this is closer:

Option Explicit
Sub FilterCities()
Dim c As Range
Dim ws As Worksheet
Dim cityListRange As Range
Dim dummyRng As Range
Dim myDataBase As Range

With Worksheets("MAIN")
Set dummyRng = .UsedRange 'try to reset lastusedcell
Set myDataBase = .Range("a5", .Cells.SpecialCells(xlCellTypeLastCell))
End With
myDataBase.Name = "Database"

'rebuild the CityList
Worksheets("cities").Columns(1).Clear
With Sheets("Main")
.Range("g5:g" & _
.Cells(.Rows.Count, "g").End(xlUp).Row).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
Unique:=True
End With

With Sheets("Cities")
Set cityListRange = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
With cityListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "CityList"
End With
End With

Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("g5").Value

'check for individual City worksheets
For Each c In Range("CityList")
If c.Value = "" Then
'do nothing
Else
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Worksheets("header").Rows("1:16").Copy _
Destination:=ws.Range("a1")
Else
Worksheets(c.Value).Rows("17:65536").Clear
End If

'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value

'transfer data to individual City worksheets
Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=Sheets(c.Value).Range("A17"), _
Unique:=False
Sheets(c.Value).Range("G15").Value = c.Value
End If
Next
MsgBox "Data has been sent"
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


I added a check for "":
If c.Value = "" Then
'do nothing

And changed the way citylist is created. Instead of using the current region
(which stops when it encounters a break in the single column data), I start at
the top and go up from the bottom.

And right near the bottom:

Sheets(c.Value).Range("G15").Value = c.Value

=============
Now the bad news. Debra has used some of the techniques that you're using on a
newer version of her file. If your code works the way you want--don't look!

Actually, you may want to take a look to see how that differs and if you can
steal anything from it.

 

[mjack003]

Thank you Dave. You have saved the day once again. I just have tw
last questions and I'll stop bugging you....for now Q1: All th
boxes are created which is a life saver on its own but how would I g
about sorting the list before distribution in ascending order. Tha
way it creates them Box 1, Box 2, Box 3 etc.?
Q2:How would I keep the same formatting from the "Main" sheet as the
are added to the "City" sheets? If I remember correctly it
paste.special but I don't know how to keep the column widths and tex
format the same.

Thanks again.

Best Regards,
Mjac

 

[Dave Peterson]

Are "box 1", "box 2", ..., "Box N" the names of the worksheets?

If yes, then Chip Pearson has some code that will sort the worksheets for you.

http://www.cpearson.com/excel/sortws.htm

When I was testing the advanced filter, it looked like it got confused when it
tried to copy the formats.

But I could do the advanced filter (in place) and copy those visible cells to
the new location.

xl2k has an option under paste|special for columnwidths, but if you're using
xl97, it won't work. But you could just loop through the columns and set the
widths:

with code copied directly from Chip's site:

Option Explicit
Sub FilterCities()
Dim c As Range
Dim ws As Worksheet
Dim cityListRange As Range
Dim dummyRng As Range
Dim myDataBase As Range
Dim iCol As Long

With Worksheets("MAIN")
Set dummyRng = .UsedRange 'try to reset lastusedcell
Set myDataBase = .Range("a5", .Cells.SpecialCells(xlCellTypeLastCell))
End With
myDataBase.Name = "Database"

'rebuild the CityList
Worksheets("cities").Columns(1).Clear
With Sheets("Main")
.Range("g5:g" & _
.Cells(.Rows.Count, "g").End(xlUp).Row).AdvancedFilter _
action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
unique:=True
End With

With Sheets("Cities")
Set cityListRange = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
With cityListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "CityList"
End With
End With

Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("g5").Value

'check for individual City worksheets
For Each c In Range("CityList")
If c.Value = "" Then
'do nothing
Else
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Worksheets("header").Rows("1:16").Copy _
Destination:=ws.Range("a1")
Else
Worksheets(c.Value).Rows("17:65536").Clear
End If

'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value

'transfer data to individual City worksheets

With Sheets("Main").Range("database")
.AdvancedFilter action:=xlFilterInPlace, unique:=True, _
CriteriaRange:=Sheets("cities").Range("d1:d2")

.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets(c.Value).Range("a17")
End With

For iCol = 1 To 7
Sheets(c.Value).Columns(iCol).ColumnWidth _
= Sheets("main").Columns(iCol).ColumnWidth
Next iCol

Sheets(c.Value).Range("G15").Value = c.Value
End If
Next
Call SortWorksheets
MsgBox "Data has been sent"
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Sub SortWorksheets()

Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index <> .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If

For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
End If
Next N
Next M
End Sub

 

[mjack003]

Hey Dave,

Works great. It sorts and updates like magic The formatting i
still off though and I don't know if it would be easier to copy th
"header" sheet all together...and then paste in the information...or t
enter formatting parameters directly into the macro. All the column
are different widths so I would think that would slow down the macro
bit resizing each column. Any ideas?

Best Regards,
Mjac

 

[Dave Peterson]

This code:

For iCol = 1 To 7
Sheets(c.Value).Columns(iCol).ColumnWidth _
= Sheets("main").Columns(iCol).ColumnWidth
Next iCol

Didn't match the columnwidths?

It should have for A:G (change that 7 in the For statement if you have more than
7 columns).

But if you wanted to delete the existing sheets and just re-add them, you could
do it this way:

Option Explicit
Sub FilterCities()
Dim c As Range
Dim ws As Worksheet
Dim cityListRange As Range
Dim dummyRng As Range
Dim myDataBase As Range
Dim iCol As Long

With Worksheets("MAIN")
Set dummyRng = .UsedRange 'try to reset lastusedcell
Set myDataBase = .Range("a5", .Cells.SpecialCells(xlCellTypeLastCell))
End With
myDataBase.Name = "Database"

'rebuild the CityList
Worksheets("cities").Columns(1).Clear
With Sheets("Main")
.Range("g5:g" & _
.Cells(.Rows.Count, "g").End(xlUp).Row).AdvancedFilter _
action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
unique:=True
End With

With Sheets("Cities")
Set cityListRange = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
With cityListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "CityList"
End With
End With

Sheets("CITIES").Range("D1").Value = _
Sheets("MAIN").Range("g5").Value

'check for individual City worksheets
For Each c In Range("CityList")
If c.Value = "" Then
'do nothing
Else
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(CStr(c.Value)).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
Worksheets("header").Rows("1:16").Copy _
Destination:=ws.Range("a1")

'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value

'transfer data to individual City worksheets

With Sheets("Main").Range("database")
.AdvancedFilter action:=xlFilterInPlace, unique:=True, _
CriteriaRange:=Sheets("cities").Range("d1:d2")

.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets(CStr(c.Value)).Range("a17")
End With

For iCol = 1 To 7
Sheets(CStr(c.Value)).Columns(iCol).ColumnWidth _
= Sheets("main").Columns(iCol).ColumnWidth
Next iCol

Sheets(CStr(c.Value)).Range("G15").Value = c.Value
End If
Next
Call SortWorksheets
MsgBox "Data has been sent"
End Sub
Sub SortWorksheets()

Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index <> .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If

For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Before:=Worksheets(M)
End If
End If
Next N
Next M
End Sub

=========
You may have noticed that I changed:
sheets(c.value)
to:
Sheets(CStr(c.Value))

It's just to make sure that if you have simple numeric entries, the code won't
get confused. I want to use the name--not the index.

 

[mjack003]

Hi Dave,

This thing is becoming a beast Somehow I missed the adjust colum
width on copy/paste. The sort worksheets macro freezes my computer fo
some reason but that's no biggie...I can do that manually. Th
formatting is still off such as text wrapping. Its small formattin
things that need to be included for presentation purposes. Would i
work to make "Header" a template and when c.value doesn't exist to cop
the whole sheet, "header", and move on from there instead of creating
blank sheet? Also wouldn't need the extra copy paste for the heade
itself. You're the expert...let me know what you think. My computer
life is at stake again

Best Regards,
Mjac

 

[mjack003]

Hey Dave,

Something like this seems to do the job. I've modified it to fit m
workbook exactly. The only thing is now for some reason its puttin
items of "Box 20" in the "Box 2" sheet, "Box 30" in "Box 3" sheet.
tried removing the "Cstr" but it still does the same thing.

ption Explicit
Sub FilterBoxes()
Dim c As Range
Dim ws As Worksheet
Dim boxListRange As Range
Dim dummyRng As Range
Dim myDataBase As Range

With Worksheets("Teardown Inventory")
Set dummyRng = .UsedRange 'try to reset lastusedcell
Set myDataBase = .Range("a5", .Cells.SpecialCells(xlCellTypeLastCell))
End With
myDataBase.Name = "Database"

'rebuild the CityList
Worksheets("Boxes").Columns(1).Clear
With Sheets("Teardown Inventory")
.Range("g5:g" & _
.Cells(.Rows.Count, "g").End(xlUp).Row).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Boxes").Range("A1"), _
Unique:=True
End With

With Sheets("Boxes")
Set boxListRange = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
With boxListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "BoxList"
End With
End With

Sheets("Boxes").Range("D1").Value = _
Sheets("Teardown Inventory").Range("g5").Value

'check for individual City worksheets
For Each c In Range("BoxList")
If c.Value = "" Then
'do nothing
Else
If WksExists(CStr(c.Value)) = False Then
Worksheets("header").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
Else
Worksheets(CStr(c.Value)).Rows("17:65536").Clear
End If

'change the criteria in the Criteria range
Sheets("Boxes").Range("D2").Value = c.Value

'transfer data to individual City worksheets
Sheets("Teardown Inventory").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Boxes").Range("D12"), _
CopyToRange:=Sheets(cstr(c.Value)).Range("A17"), _
Unique:=False
Sheets(CStr(c.Value)).Range("E13").Value = c.Value
End If
Next
MsgBox "Data has been sent"
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

All I really changed is the ".sheets.add" to copy the header sheet.

Best Regards,
Mjac

 

[Dave Peterson]

The "box 2" and "box 20" and "box 223412341234" will all go to the same sheet.
That's a limitation of the way we did the advanced filter. Unless you do
something nice, advanced filter treats it as "begins with".

But Debra Dalgleish has updated her code to fix this potential problem. (and
you stole your code too early!).

'change the criteria in the Criteria range
Sheets("Boxes").Range("D2").Value = c.Value
could become:
Sheets("boxes").Range("D2").Value = "=" & Chr(34) & "=" & c.Value & Chr(34)


====
And in the previous post, I had code that deleted the existing sheet and just
recreated it from scratch.

And just from a coordination point of view, I wouldn't make the Header sheet a
template (a separate workbook).

But I would have a "template" worksheet named header. I'd copy that to create
the new worksheet (instead of adding from the external template).

I'd be afraid that I might delete the template workbook by mistake. By keeping
the "template" within the workbook, I could only destroy the whole thing!

 

[mjack003]

Very nice! Works perfectly formatting and all. About the header sheet
I had just left it in the workbook as a sheet but tweaked it a bit s
that it was a "template" per say Anyway it works great and I'
lovin it. Thanks again for your time Dave. This one was a doozey.

Best Regards,
Mjac

 

[Dave Peterson]

Just to add one more post to the thread <vbg>

Woohoo!