URGENT!!Copy rows to a new workbook on conditions

[clwong]

Dear all,

I think I need a macro to help to copy rows to a new workbook on condition after sorting

A given workbook(sales.xls) inculding a worksheet of thousands of rows and 10 columns(A...J) like as following:
---------------Sample Sheet------------------
A B C(salescode) D(amt) E(qty) F .... J
1 CA 6 CK 180 8
2 CN 5 JB 69 4
3 CN 8 MJ 30 3
4 CA 5 CK 100 7

Remark: column C is the salescode like CK which is equal to Clive_KUEN
--------------------------------------------
I would like to sort data with cloumn C first and then extract columns A,B,C,D,E to a new workbook with filename as the sales name of column C respectively(i.e. after sorting, if rows having column C equal to CK, the new filenames will be Clive_KUEN.xls and so on );
besides in this new worksheet, a new column should be created between column D and E of sales.xls and which value is equal to D1/E1 with 4 decimal.

It is very difficult for me as I am just a beginner.

Thanks a lot.

Regards,
CL
email: cl.wong@hongkong.com

 

[Jay Petrulis]

Hi,

The following routine does the following:

1. Determines the number of uniques entries in column 3 (sales code) on a sheet called "Main" which houses the data.

2. Adds a sheet for each salecode entry to the existing workbook.

3. Copies the relevant data from the main sheet to each sales code sheet.

4. Copies each sales code sheet to a new workbook, although they are not named.

Sub Run_File()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Application.Run ("Add_Sheets")
Application.Run ("Find_Name_Code")

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub


Private Sub Find_Name_Code()
Dim lastcol As Integer, x As Long
Dim lastrow As Long, lastrow2 As Long
Dim MyArr()
Dim DataRange As Range


With Sheets("Main")
    Set DataRange = .UsedRange
    
    lastrow = .Cells(65536, 3).End(xlUp).Row
    lastcol = .Cells(1, 1).End(xlToRight).Column
    
    .Columns(lastcol + 2).ClearContents
    .Range("C1:C" & lastrow).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=.Cells(1, lastcol + 2), Unique:=True
    .Cells(1, lastcol + 2).Delete shift:=xlUp
    
    lastrow2 = .Cells(65536, lastcol + 2).End(xlUp).Row
    ReDim MyArr(1 To lastrow2)
    For x = 1 To lastrow2
        MyArr(x) = .Cells(x, lastcol + 2)
    Next x
    .Columns(lastcol + 2).ClearContents
    
    For x = 1 To lastrow2
        .Cells(1, 3).AutoFilter Field:=3, Criteria1:=MyArr(x)
        DataRange.SpecialCells(xlCellTypeVisible).Copy Sheets(MyArr(x)).Range("A1")
        Sheets(MyArr(x)).Copy
        ThisWorkbook.Activate
    Next x
    .Cells(1, 3).AutoFilter
End With
End Sub


Private Sub Add_Sheets()
Dim lastrow As Long, sheettoname As String, x As Long
lastrow = Sheets("Main").Cells(Rows.Count, 3).End(xlUp).Row

For x = 2 To lastrow
    sheettoname = Sheets("Main").Cells(x, 3)
    If SheetExists(sheettoname) = True Then
    ' do nothing
    Else
    Worksheets.Add After:=Sheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = Sheets("Main").Cells(x, 3).Value
    End If
Next x
Sheets("Main").Select
End Sub

Private Function NameofSheet()
    NameofSheet = Application.Caller.Parent.Name
End Function

Private Function SheetExists(sheetname) As Boolean
Dim abc As Object
On Error Resume Next
Set abc = ActiveWorkbook.Sheets(sheetname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function

Let me know how this works for you, and then the extras can be added.

Bye,
Jay

 

[clwong]

Jay,
Thanks a for your kind help.
But, soem error shown after coping the code to a new workbook (main.xls) with a "Main" sheet and run it.
Error code:
"Run time error 1004"
"Application-defined or object-defined error"

After run Debug, it point to following line:

.Columns(lastcol + 2).ClearContents

Could u help to solve it?
Thanks.

 

[Jay Petrulis]

On 2002-05-03 01:06, clwong wrote:
Jay,
Thanks a for your kind help.
But, soem error shown after coping the code to a new workbook (main.xls) with a "Main" sheet and run it.
Error code:
"Run time error 1004"
"Application-defined or object-defined error"

After run Debug, it point to following line:

.Columns(lastcol + 2).ClearContents

Could u help to solve it?
Thanks.

If possible, would you send me the file (or a sample of it)? I did not get the error, but somehow the reference to the main sheet is not working properly. Should be an easy fix.

john.petrulis@notes.ntrs.com

and I'll have a look.

Thanks,
Jay

 

[DaBears]

The macro above works perfect for what i'm trying to do as well. However I would like to change two things.
1) Where you have letters under your sales code I have numbers and it gives me an error. When i try to debug the error it highlights the following line of code.
DataRange.SpecialCells(xlcelltypevisible).copysheets(MyArr(x)).Range("A1"). When i use letters it works fine.
2) My "sales code" is in a differant column. What do I change in the macro to change this column to lets say column T.

Thanks in advance for the help.

 

[DaBears]

Any help on this one would be greatly appreciated. If you need more info let me know.