Solved: Alter this VBA for me in Excel?

Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

slurpee55

Thread Starter
Joined
Oct 20, 2004
Messages
7,837
I have some code from long ago that kept my original data but also wrote the related data to new worksheets based on a change in column A (it said Region 1, Region 2, etc. there).

Now I want to do much the same thing based on a sample with the listings of states as the breaking point - that is, a different worksheet for each of the 36 states that appear in this rather large sample.

The code I have from before is:
Code:
Sub Split_Page_at_Change()
Application.ScreenUpdating = False
For i = 1 To 29
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Region " & i
Sheets("Sheet1").Range("A1:L1").Copy Range("A1")
Next i

Sheets("Sheet1").Select
x = Rows.Count
For Each Cell In Range("A2", Range("A2").End(xlDown))
Cell.Resize(1, 12).Copy Sheets(Cell.Value).Range("A" & x).End(xlUp).Offset(1)
Next Cell

Application.ScreenUpdating = True
End Sub
You can see it had 29 regions and it named each page Region 1, Region 2, etc but I would rather have the new worksheets draw their names from the abbreviations for the states, which are in column E (of course, I could move this, but it is a better layout with it there, following the cities!)

Thanks gang, and have wonderful holidays!!!! :D (y)
 
Joined
Jul 1, 2005
Messages
8,546
"the abbreviations for the states, which are in column E" is your idea of adequate info? :D

E1 = "State" -- E2 = "AL" -- E3 = "AZ" (the two that jumped in my head).

Sub test()
Homesheet = ActiveSheet.Name
For i = 1 To 2
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Sheets(Homesheet).Cells(i + 1, 5)
Next i
End Sub


adds an "AL" sheet and an "AZ" sheet. The "Cells" syntax is Cells(r,c) -- thus the first pass is Cells(r2,c5) (E2), the second is Cells(r3,c5) (E3).

See?

Season's greetings Loche. :)
 

slurpee55

Thread Starter
Joined
Oct 20, 2004
Messages
7,837
Almost, except E2 through E14 are AL, and then E15 through E98 are AR, E99 is the only AZ, and so on.
 

slurpee55

Thread Starter
Joined
Oct 20, 2004
Messages
7,837
So, like the following - which I use for putting in page breaks where there is a change in a column - I want to read down column E and make a new page when that changes and only include the data where the column E is all alike.

Code:
Sub Page_Break_at_Change()
Do Until ActiveCell = ""
If ActiveCell <> ActiveCell.Offset(1, 0) Then
ActiveCell.Offset(1, 0).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=ActiveCell
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub
 
Joined
Jul 1, 2005
Messages
8,546
So ... you should set up a unique list in a free area first, and then loop through that?

Last_E = Range("E" & Rows.Count).End(xlUp).Row
Range("E1:E" & Last_E).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("M1"), Unique:=True
 

slurpee55

Thread Starter
Joined
Oct 20, 2004
Messages
7,837
So do essentially the same as a pivot table listing - only making a range in a column off to one side?
But then what? Not following...(I was out watching the eclipse late last night....)
 
Joined
Jul 1, 2005
Messages
8,546
"essentially the same as a pivot table listing", yes.

You can do it virtually if that's more your kind of "methodology", but at least ditch the ActiveCell.Offset(1, 0).Select horror.

Sub uniques()
Last_E = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Range("E2:E" & Last_E)
If Cell <> Cell.Offset(-1) Then
MsgBox Cell 'substitute whatever else you need it to do here
End If
Next Cell
End Sub
 
Joined
Jul 1, 2005
Messages
8,546
A little more:

Sub uniques()
Last_E = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Range("E2:E" & Last_E)
If Cell <> Cell.Offset(-1) Then
NewSheet = Cell.Value
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = NewSheet

End If
Next Cell
End Sub
 

slurpee55

Thread Starter
Joined
Oct 20, 2004
Messages
7,837
LOL! The "ActiveCell.Offset(1, 0).Select horror" - hey, someone else wrote that for me and it works, whether it is good coding or not.
As for post # 8, that gives me all the new sheets I want but doesn't copy over the data related to them value in column E (and I want to copy what is in row #1, which consists of ID, name, city, ST, ZIP, etc., as a header to all the new sheets.)
Can you add that - maybe by matching the data in E to the sheet name???
 

Keebellah

Hans
Trusted Advisor
Joined
Mar 27, 2008
Messages
6,612
Hi, I'd like to take a look, see if you have a sample for me to work with.
I'm off on a 12 day holiday on the 24th so won't be able to do too much.
I'll be back on-line after the3d of January, but if you post a sample today I might get the results working. At least I think I understand what you need.
If I don't see anyhting, Marry X'Mas and a Happy 2011.

:) :) :)
 
Joined
Jul 1, 2005
Messages
8,546
"I want to copy what is in row #1" I understand.

"the data related to them value in column E" I don't understand -- unless you mean you want the (e.g.) AL rows to be copied to the new AL sheet.

Sub uniques()
Last_E = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Sheets("Sheet1").Range("E2:E" & Last_E)
If Cell <> Cell.Offset(-1) Then
NewSheet = Cell.Value
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = NewSheet
Sheets("Sheet1").Range("A1:J1").Copy Range("A1")
End If
Next Cell
End Sub


EDIT: is this it? :D

Sub uniques()
Last_E = Range("E" & Rows.Count).End(xlUp).Row
For Each Cell In Sheets("Sheet1").Range("E2:E" & Last_E)
If Cell <> Cell.Offset(-1) Then
ST_Rows = WorksheetFunction.CountIf(Sheets("Sheet1").Columns(5), Cell.Value)
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Cell.Value
Sheets("Sheet1").Range("A1:J1").Copy Range("A1")
Sheets("Sheet1").Cells(Cell.Row, 1).Resize(ST_Rows, 10).Copy Range("A2")
End If
Next Cell
End Sub
 
Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 807,865 other people just like you!

Latest posts

Top