0
Thanks

A few words of thanks would be greatly appreciated.

Excel - A macro to create new workbook and copy data

Issue

I am looking for macro to copy rows based on partial cell content of a column. I have an excel spreadsheet called "arc.xlsx" from which I would like to copy data to other few new excel files when certain criteria are met. The excel file contained location is C:\Documents and Settings\xxxx\Desktop\Company. Am only a beginner in Excel.

Below is a sample of arc.xlsx

GP      BR      CUST_NO CUST_NAME       day     mo      year 
I1      01      999999  SMITH   00      08      09 
I1      ab      999999  SMITH   04      08      09 
I1      cd      999999  SMITH   04      10      09 
I1      01      999999  SMITH   04      01      10 
I1      02      999999  SMITH   27      02      10 
I1      01      999999  SMITH   27      02      10 
I1      cd      999999  SMITH   02      03      10 
I1      cd      999999  SMITH   04      03      10 
I1      cd      999999  SMITH   30      07      09 
I1      ab      999999  SMITH   30      07      09 
I1      02      999999  SMITH   30      07      09 
  • I would like the macro to copy rows that have 'ab' in the column B (with title BR)and save it in a new excel file with name ab.xlsx in the same location folder.
  • And athe same for 'cd', '01' and '02' by saving the data in files with name cd.xlsx, 01.xlsx so on.

Solution

1. MAKE A BACKUP OF YOUR WORKBOOK

2. Open the work book

3. Press ALT + F11 (both ALT key and F11 key at the same time). This open VBE

4. From the menu of VBE, click on Insert and then choose on Module by clicking on it. This will open a blank module

5. Copy the code give after the instructions by selecting the code (will be found after the instructions) and pressing CTRL + C (both keys at the same time)

6. Paste the code in the newly added module (see step 4) by clicking on the module and pressing CTRL + V (again both at the same time)

7. Make sure there is no red line in the pasted code.

8. Press F5 to run the macro.

9 Check the documents in the default location where generally excel saves the file.

HERE IS THE CODE

Sub details()

Dim thisWB  As String

Dim newWB As String

    thisWB = ActiveWorkbook.Name
    
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
    
    Sheets("Sheet1").Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        
        On Error Resume Next
        
        ActiveSheet.ShowAllData
        
        On Error GoTo 0
    
    End If
    
    Columns("B:B").Select
    Selection.Copy
    
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
        
        If lastrow <> Rows.Count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
    
    End If
    
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
    
    Columns("A:A").Delete
    
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    
    lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
    
    For suppno = 2 To lMaxSupp
    
        Windows(thisWB).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
        
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
            
            Windows(thisWB).Activate

            Sheets("Sheet1").Select
            Cells.Select
            
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
            
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
            
            lastrow = Cells(Rows.Count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
            
            Windows(newWB).Activate
            ActiveSheet.Paste

            ActiveWorkbook.Save
            ActiveWorkbook.Close
            
        End If
    
    Next
    
    Sheets("tempsheet").Delete
    
    Sheets("Sheet1").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

Thanks to Rizvisa1 for this tip.

0
Thanks

A few words of thanks would be greatly appreciated.

Ask a question
CCM is a leading international tech website. Our content is written in collaboration with IT experts, under the direction of Jean-François Pillou, founder of CCM.net. CCM reaches more than 50 million unique visitors per month and is available in 11 languages.
This document, titled « Excel - A macro to create new workbook and copy data », is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).