Code Help

MarkAndrews

Well-known Member
Joined
May 2, 2006
Messages
1,963
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
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

ravi4ever

Active Member
Joined
Apr 13, 2010
Messages
316
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..

Code:
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
 
Last edited:

ravi4ever

Active Member
Joined
Apr 13, 2010
Messages
316
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

Well-known Member
Joined
May 2, 2006
Messages
1,963
In the end I didn't need this as a solution

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

Mark
 

Watch MrExcel Video

Forum statistics

Threads
1,123,318
Messages
5,600,925
Members
414,416
Latest member
Nobu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top