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 SettingsxxxxDesktopCompany. 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.