delete all rows except those meeting criterias

[J.W. Aldridge]

Headers on row 1.
Data in A:AD
Criteria in column B.

Delete rows if the value in row B does not equal "Apples" or "oranges"

Then create sheets based on value in A, and copy the data onto each
sheet based on the data in A and the name of sheet.

 

[Ryan H]

This will delete the rows for you. Hope this helps! If so, let me know,
click "YES" below.

Sub DeleteRows()

Dim LastRow As Long
Dim rw As Long

Application.ScreenUpdating = False

LastRow = Cells(Rows.Count, "B").End(xlUp).Row

For rw = LastRow To 2 Step -1
If Cells(rw, "B").Value <> "Apples" Or Cells(rw, "B").Value <>
"Oranges" Then
Rows(rw).Delete Shift:=xlUp
End If
Next rw

Application.ScreenUpdating = True

End Sub

You are vague on the criteria for the second part. Please explain in
further detail.

 

[JLGWhiz]

Hi Jeremy, Not sure what this means.

Then create sheets based on value in A, and copy the data onto each
sheet based on the data in A and the name of sheet.

 

[J.W. Aldridge]

This is what i meant...
Create sheets based on value in column A.
Transfer data to each created sheet based on names in column A.

Tried adapting to what i need, but getting error on

Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)


Sub Create_sheets_from_data()
'copy rows to worksheets based on value in column A
'assume the worksheet name to paste to is the value in Col A
Dim CurrentCell As Range
Dim SourceRow As Range
Dim Targetsht As Worksheet
Dim TargetRow As Long
Dim CurrentCellValue As String


'start with cell A1 on Sheet1
Set CurrentCell = Worksheets("ERRORS").Cells(1, 1) 'row 1 column 1


Do While Not IsEmpty(CurrentCell)
CurrentCellValue = CurrentCell.Value
Set SourceRow = CurrentCell.EntireRow


'Check if worksheet exists
On Error Resume Next
Testwksht = Worksheets(CurrentCellValue).Name
If Err.Number = 0 Then
'MsgBox CurrentCellValue & " worksheet Exists"
Else
'TO INSERT SHEETS BEFORE A SPECIFIED SHEET, CHANGE NAME
BELOW(END)
'Worksheets.Add(before:=Sheets("TA_END")).Name =
CurrentCellValue
End If


On Error GoTo 0 'reset on error to trap errors again


Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)
'note: using CurrentCell.value gave me an error if the value was
numeric


' Find next blank row in Targetsht - check using Column A
TargetRow = Targetsht.Cells(Rows.Count, 1).End(xlUp).Row + 1
SourceRow.Copy Destination:=Targetsht.Cells(TargetRow, 1)


'do the next cell
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop
End Sub

 

[JLGWhiz]

Are you sure that the variable "CurrentCellValue" equates to a worksheet
name or index number? It looks like it worked earlier where you used the
variable "Testwksht".

 

[Ryan H]

Ok, I think I understand what you are trying to do. You are trying to scan
each cell in Col.A in Sheet("ERRORS"), which is your "source". And within
each cell is a sheet name. You want to find that sheet within the workbook
and then paste that cells entire row in the sheet that was found. If the
sheet is not in the workbook, you want to create a new sheet before
Sheets("TA_END") and copy that cells row to it. Am I right?

If so, I took the liberty to rewrite your code. I wouldn't recommend you
using On Error Resume Next because it can cause a lot of problems when trying
to debug code. I tested this code and it worked for me. Hope this helps!
If so, let me know, click "YES" below.

Option Explicit

Sub Create_Sheets_From_Data()

Dim LastRow As Long
Dim rngSource As Range
Dim rng As Range
Dim wks As Worksheet
Dim bolSheetExists As Boolean

Application.ScreenUpdating = False

' set range of cells to loop thru in source worksheet
With Sheets("ERRORS")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rngSource = .Range("A1:A" & LastRow)
End With

' loop thru each cell in Source range
For Each rng In rngSource

' test if worksheet exists
For Each wks In Sheets
If rng.Value = wks.Name Then
bolSheetExists = True
Exit For
End If
Next wks

If bolSheetExists Then
' if sheet exists find lastrow and copy rng source row
LastRow = wks.Cells(Rows.Count, "A").End(xlUp).Row
rng.EntireRow.Copy Destination:=wks.Range("A" & LastRow + 1)
Else
' if sheet doesn't exist, create sheet and copy rng source row
Worksheets.Add(Before:=Sheets("TA_END")).Name = rng.Value
rng.EntireRow.Copy Destination:=Sheets(rng.Value).Range("A1")
End If
bolSheetExists = False
Next rng

Application.ScreenUpdating = True

End Sub