1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Solved: Alter this VBA for me in Excel?

Discussion in 'Business Applications' started by slurpee55, Dec 21, 2010.

Thread Status:
Not open for further replies.
Advertisement
  1. slurpee55

    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)
     
  2. bomb #21

    bomb #21

    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. :)
     
  3. slurpee55

    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.
     
  4. slurpee55

    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
     
  5. bomb #21

    bomb #21

    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
     
  6. slurpee55

    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....)
     
  7. bomb #21

    bomb #21

    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
     
  8. bomb #21

    bomb #21

    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
     
  9. slurpee55

    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???
     
  10. slurpee55

    slurpee55 Thread Starter

    Joined:
    Oct 20, 2004
    Messages:
    7,837
    Oh, and the original data is on Sheet1, as you might expect.
     
  11. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,597
    First Name:
    Hans
    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.

    :) :) :)
     
  12. slurpee55

    slurpee55 Thread Starter

    Joined:
    Oct 20, 2004
    Messages:
    7,837
    I'll make up a copy of some fake data and upload that sheet.
     
  13. slurpee55

    slurpee55 Thread Starter

    Joined:
    Oct 20, 2004
    Messages:
    7,837
    Here's that sheet I promised. The real worksheet has 13514 listings in it, so you can see why I don't want to copy things manually. :p
     

    Attached Files:

  14. bomb #21

    bomb #21

    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
     
  15. Keebellah

    Keebellah Trusted Advisor

    Joined:
    Mar 27, 2008
    Messages:
    6,597
    First Name:
    Hans
    got the sample:)
     
  16. Sponsor

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 733,556 other people just like you!

Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/969863

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice