macro that can copy each persons’ info in a list to a auto-g - Page 2
Eliminate Pivot Table Annoyances
Thanks Thanks:  0
Likes Likes:  0
Page 2 of 2 FirstFirst 12
Results 11 to 14 of 14

Thread: macro that can copy each persons’ info in a list to a auto-g

  1. #11
    Board Regular
    Join Date
    Feb 2002
    Location
    Houston, TX
    Posts
    357
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

     
    Any suggestions on improving this?

    Working Code:

    Sub CreateSheets()

    'Makes sure that the status bar is visible
    Application.DisplayStatusBar = True

    'Enter message for status bar
    Application.StatusBar = "Performing Task!! Please Wait!!"

    'Turn off Screen updating
    Application.ScreenUpdating = False

    Dim NameRange As String

    NameRange = Range("A1", Range("A65536").End(xlUp).Address).Address

    Range(NameRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    Range("A2", Range("A65536").End(xlUp).Address).Select
    RowCounter = Selection.Count

    Dim sheetname As String
    Dim Exists As Boolean

    For i = 2 To RowCounter + 1
    Sheets("Names").Select
    sheetname = Range("A" & i).Value

    For Each ws In Sheets
    If ws.Name = sheetname Then
    Exists = True
    If Exists = True Then GoTo StartAgain:
    End If
    Next ws

    Sheets.Add
    ActiveSheet.Select
    ActiveSheet.Name = sheetname

    StartAgain:
    Next i

    Sheets("Names").Select

    ActiveSheet.ShowAllData

    'Turn On Autofilter
    Columns("A:D").Select
    Selection.AutoFilter

    For Each ws In Sheets

    If ws.Name <> "Names" Then

    Selection.AutoFilter Field:=1, Criteria1:=ws.Name
    Range("A1").Select

    'This makes the range A1 to
    'Edge of range that would contain all data even if that cell is empty
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    ws.Paste

    End If

    Next ws

    'Turn Off Autofilter
    Columns("A:D").Select
    Selection.AutoFilter

    'Turn on Screen Updating
    '(Happens automatically after a module is finished)
    Application.ScreenUpdating = True

    'Reset the Status Bar
    Application.StatusBar = False

    End Sub


  2. #12
    Board Regular
    Join Date
    Feb 2002
    Location
    Houston, TX
    Posts
    357
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    Sorry for the long pages or code, people!!

  3. #13
    MrExcel MVP Jay Petrulis's Avatar
    Join Date
    Mar 2002
    Location
    Chicago, IL USA
    Posts
    2,040
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    Some code rewritten. Posted without the comments.

    General notes:
    1. Variables are declared (Dim) at the top of the module.
    2. The Exists code is removed because you don't need to test a condition and assign it to a variable, then test the variable here.
    3. Avoid .Select unless it is necessary. (e.g. when you add a sheet, the sheet automatically becomes the active sheet, no need to select)

    ---------------
    Sub CreateSheets()
    Dim sheetname As String
    Dim NameRange As String

    Application.DisplayStatusBar = True
    Application.StatusBar = "Performing Task!! Please Wait!!"
    Application.ScreenUpdating = False

    NameRange = Range("A1", Range("A65536").End(xlUp).Address).Address
    Range(NameRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    Range("A2", Range("A65536").End(xlUp).Address).Select
    RowCounter = Selection.Count

    For i = 2 To RowCounter + 1
    Sheets("Names").Select
    sheetname = Range("A" & i).Value
    For Each ws In Sheets
    If ws.Name = sheetname Then GoTo StartAgain
    Next ws
    Sheets.Add
    ActiveSheet.Name = sheetname
    StartAgain:
    Next i
    Sheets("Names").Select
    ActiveSheet.ShowAllData
    Columns("A:D").AutoFilter
    For Each ws In Sheets
    If ws.Name <> "Names" Then
    [A1].AutoFilter Field:=1, Criteria1:=ws.Name
    Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).Copy
    ws.Paste
    End If
    Next ws
    Columns("A:D").AutoFilter
    Application.ScreenUpdating = True
    Application.StatusBar = False

    End Sub
    --------------------------

    Bye,
    Jay

  4. #14
    Board Regular
    Join Date
    Feb 2002
    Location
    Guderup, Denmark
    Posts
    288
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

      
    Sub AutoFilterModel()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim x, i As Long, a, y As Integer
    Dim TempMatrix As Variant
    x = Application.WorksheetFunction.CountA(Range("A:A"))
    ReDim matrix(x)
    ReDim TempMatrix(x, 1)
    a = 0
    TempMatrix = Range("A1:A" & x).Value
    For i = 2 To x
    If TempMatrix(i, 1) <> TempMatrix(i - 1, 1) Then
    a = a + 1
    matrix(a) = TempMatrix(i, 1)
    End If
    Next i
    StartSheet = ActiveSheet.Name
    For y = 1 To a
    Selection.AutoFilter Field:=1, Criteria1:=matrix(y)
    Selection.CurrentRegion.Copy
    Sheets.Add
    ActiveSheet.Name = matrix(y)
    Range("A1").PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False
    Sheets(StartSheet).Select
    Next
    Selection.AutoFilter
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    End Sub

    regards Tommy

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

 
DMCA.com