Code Help

[MarkAndrews]

I need some help with some code

I have a sheet populated in columns A:N (Named “PPR Dump”)

Row 1 contains column headings

Column D contains a Stock_Code

What I need to do I create a macro which looks at Column D then

1. Creates a new sheet for each code in this column (Unique)
2. Pastes all columns relevant to that stock code and all occurances onto the appropriate sheet (Keeping the original data on “PPR Dump”)

I tried editing the following code, but I am stumped!

Option Explicit


Sub Unique()


Dim lngLastRow As Long, lngCalc As Long
Dim rngCustomerNumbers As Range, rngCell As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlManual
End With

With Sheets("PPR DUMP")
lngLastRow = .Range("D" & Rows.Count).End(xlUp).Row
Set rngCustomerNumbers = .Range("D1:A" & lngLastRow)
End With

With Sheets("Unique")
lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:A" & lngLastRow).Clear
rngCustomerNumbers.AdvancedFilter xlFilterCopy, , .Range("D1"), True
lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
For Each rngCell In .Range("A2:A" & lngLastRow)
With Sheets("Master")
.AutoFilterMode = False
Sheets.Add(, Sheets(Sheets.Count)).Name = rngCell.Value
lngLastRow = .Range("D" & Rows.Count).End(xlUp).Row
With .Range("D1:A" & lngLastRow)
.AutoFilter field:=1, Criteria1:=rngCell.Value
.EntireRow.Copy ActiveSheet.Range("D1")
.AutoFilter
End With
End With
Next rngCell
On Error GoTo 0
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With

Sheets("Unique").Activate
MsgBox "Excel has added " & Worksheets.Count - 2 & " New worksheets"

Set rngCustomerNumbers = Nothing
Set rngCell = Nothing


End Sub

Thanks in advance

 

[ravi4ever]

Hi Mark, try this and let me know if any change is required.. The data is sorted in a temporary sheet by column D and all the sheets are generated from that data, hope sorting is fine else use the same logic and use Autofilters..

Sub CreateReport()

'Create multi-sheets
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlManual
        .DisplayAlerts = False
    End With

    Sheets("PPR DUMP").Copy After:=Sheets(Sheets.Count)
    Set wb = ThisWorkbook
    Set ws = Sheets(Sheets.Count)
    LR = ws.Cells(Rows.Count, "A").End(xlUp).Row
    ws.Range("A1:N" & LR).Sort Key1:=ws.Columns("D"), Order1:=xlAscending, Header:=xlYes
    ws.Range("D2:D" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("Z1"), Unique:=True

    For i = 2 To ws.Range("Z65536").End(xlUp).Row
        Application.StatusBar = "Creating Stock Code Sheets.. " & Round((i / (ws.Range("Z65536").End(xlUp).Row) * 100), 0) & "% Done | Stock Code :" & ws.Cells(i, "Z").Value
'        wb.Sheets.Add After:=wb.Sheets(Sheets.Count)
'        ActiveSheet.Name = ws.Cells(i, "Z").Value
        wb.Sheets.Add(, Sheets(Sheets.Count)).Name = ws.Cells(i, "Z").Value
        ws.Range("A1:L2").Copy Destination:=wb.Sheets(Sheets.Count).Range("A1")
        stk_code = ws.Cells(i, "Z").Value
        firstrow = ws.Range("D2:D" & LR).Find(stk_code, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
        endrow = ws.Range("D2:D" & LR).Find(stk_code, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        dRange = "A" & firstrow & ":N" & endrow
        ws.Range(dRange).Copy Destination:=wb.Sheets(Sheets.Count).Range("A2")
        Application.GoTo wb.Sheets(1).Cells(1, 1)
    Next i

    ws.Delete
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = False
        Application.StatusBar = ""
    End With

    Application.GoTo wb.Sheets("Unique").Cells(1, 1)
    MsgBox "Excel has added " & Worksheets.Count - 2 & " New worksheets"

End Sub

 

[MarkAndrews]

Thanks Ravi,

It errors on

wb.Sheets.Add(, Sheets(Sheets.Count)).Name = ws.Cells(i, "Z").Value

 

[ravi4ever]

Its working fine with Excel 2003-2010, probably the sheet have data beyond columns A:N.. if so then adjust the column Z with the last column +1..

 

[MarkAndrews]

In the end I didn't need this as a solution

But i do thankyou for your time & my delay in replying

Mark