Results 1 to 3 of 3
  1. #1
    Silver Lounger
    Join Date
    Dec 2000
    Location
    Northampton, Northamptonshire, England
    Posts
    1,951
    Thanks
    2
    Thanked 1 Time in 1 Post

    Seperate Data (Excel 2002)

    Hi

    This code was kindly supplied by Hans

    I am trying to adapt it to the attached workbook but it just keeps deleting everything.

    What I need it to do is at every change in surname B3 create new tab and copy all columns and rows of data to the relevant tab which is A to EC

    Many Thanks

    Braddy

    Public Sub Separate()
    Dim oSrc As Worksheet, oTgt As Worksheet
    Dim lTgtRow As Long
    Dim oCpyStart As Range, oCpyRange As Range, oNxtCell As Range
    Application.ScreenUpdating = False
    Set oSrc = Worksheets("Master")
    oSrc.Range("A4", Range("D65536").End(xlUp).Offset(0, 3)).Sort key1:=Range("D2"), _
    Order1:=xlAscending, header:=xlNo
    Set oCpyStart = oSrc.Range("D4")
    For Each oTgt In Worksheets
    If oTgt.Name <> "Master" Then
    oTgt.Cells.Clear
    End If
    Next oTgt
    Do While oCpyStart.Value <> ""
    Set oTgt = Nothing
    Set oNxtCell = oCpyStart.Offset(1, 0)
    Do While oCpyStart.Value = oNxtCell.Value
    Set oNxtCell = oNxtCell.Offset(1, 0)
    Loop
    Set oCpyRange = Range(oCpyStart.Offset(0, -3), oNxtCell.Offset(-1, 3))
    On Error Resume Next
    Set oTgt = Worksheets(oCpyStart.Value)
    On Error GoTo 0
    If oTgt Is Nothing Then
    Set oTgt = Worksheets.Add(After:=Worksheets(Worksheets.Count) )
    oTgt.Name = oCpyStart.Value
    End If
    oSrc.Range("A1:EC1").Copy Destination:=oTgt.Range("A1")
    oCpyRange.Copy Destination:=oTgt.Range("A65536").End(xlUp).Offset (1, 0)
    oTgt.Cells.EntireColumn.AutoFit
    Set oCpyStart = oNxtCell
    Loop
    oSrc.Activate
    Application.ScreenUpdating = True
    End Sub
    If you are a fool at forty, you will always be a fool

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: Seperate Data (Excel 2002)

    I think the code was supplied by one of my fellow Loungers (Legare?). Try this variation:

    Public Sub Separate()
    Dim oSrc As Worksheet, oTgt As Worksheet
    Dim lTgtRow As Long
    Dim oCpyStart As Range, oCpyRange As Range, oNxtCell As Range

    Application.ScreenUpdating = False

    Set oSrc = Worksheets("Master")
    oSrc.Range("A3").CurrentRegion.Sort Key1:=Range("B3"), _
    Order1:=xlAscending, Header:=xlYes
    For Each oTgt In Worksheets
    If oTgt.Name <> "Master" Then
    oTgt.Cells.Clear
    End If
    Next oTgt
    Set oCpyStart = oSrc.Range("B4")
    Do While oCpyStart.Value <> ""
    Set oTgt = Nothing
    Set oNxtCell = oCpyStart.Offset(1, 0)
    Do While oCpyStart.Value = oNxtCell.Value
    Set oNxtCell = oNxtCell.Offset(1, 0)
    Loop
    Set oCpyRange = Range(oCpyStart.Offset, oNxtCell.Offset(-1, 0)).EntireRow
    On Error Resume Next
    Set oTgt = Worksheets(oCpyStart.Value)
    On Error GoTo 0
    If oTgt Is Nothing Then
    Set oTgt = Worksheets.Add(After:=Worksheets(Worksheets.Count) )
    oTgt.Name = oCpyStart.Value
    End If
    oSrc.Range("A3:EC3").Copy Destination:=oTgt.Range("A1")
    oCpyRange.Copy Destination:=oTgt.Range("A65536").End(xlUp).Offset (1, 0)
    oTgt.Cells.EntireColumn.AutoFit
    Set oCpyStart = oNxtCell
    Loop
    oSrc.Activate

    Application.ScreenUpdating = True
    End Sub

  3. #3
    Silver Lounger
    Join Date
    Dec 2000
    Location
    Northampton, Northamptonshire, England
    Posts
    1,951
    Thanks
    2
    Thanked 1 Time in 1 Post

    Re: Seperate Data (Excel 2002)

    Hi Hans

    First of all my sincere apologies to Legare.

    The code is excellent

    Many thanks to you both.

    Braddy
    If you are a fool at forty, you will always be a fool

Posting Permissions

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