Excel - A macro to create new workbook and copy data

December 2016



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.

Related :

This document entitled « Excel - A macro to create new workbook and copy data  » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.