Error Checking in Excel
Thanks Thanks:  0
Likes Likes:  0
Results 1 to 6 of 6

Thread: URGENT!!Copy rows to a new workbook on conditions

  1. #1
    New Member
    Join Date
    Mar 2002
    Location
    Hong Kong
    Posts
    38
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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






  2. #2
    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

    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.

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

  3. #3
    New Member
    Join Date
    Mar 2002
    Location
    Hong Kong
    Posts
    38
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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.

  4. #4
    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

    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

  5. #5
    New Member
    Join Date
    Aug 2010
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: URGENT!!Copy rows to a new workbook on conditions

    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.

  6. #6
    New Member
    Join Date
    Aug 2010
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: URGENT!!Copy rows to a new workbook on conditions

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

Some videos you may like

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
  •