slecting data???

[Lime]

if I want to look for only certin data in a column say (Drg) and move the
whole row of data to a new sheet in the workbook an call it " Errors" does
anyone know how to approach?

Thanks,
Lime

 

[Jim Thomlinson]

Give this a try...

Sub MoveErrors()
Dim wksCurrent As Worksheet
Dim wksNew As Worksheet
Dim rngFirst As Range
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngToSearch As Range
Dim strToFind As String

strToFind = "DRG"
Set wksCurrent = Sheets("Sheet1")
Set rngToSearch = wksCurrent.Columns("C")
Set rngFound = rngToSearch.Find(What:=strToFind, LookAt:=xlWhole)
If rngFound Is Nothing Then
MsgBox "Sorry. Nothing to Move"
Else
Set wksNew = Worksheets.Add
Set rngFirst = rngFound
Set rngAllFound = rngFound.EntireRow
Do
Set rngAllFound = Union(rngAllFound, rngFound.EntireRow)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
rngAllFound.Copy
wksNew.Range("A2").PasteSpecial xlPasteValues
rngAllFound.Delete
Application.CutCopyMode = False
End If
End Sub

 

[Lime]

Great that brought it over but not the header or the format. What if I want
to pull a string can I pull at once?

 

[Jim Thomlinson]

Sub MoveErrors()
Dim wksCurrent As Worksheet
Dim wksNew As Worksheet
Dim rngFirst As Range
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngToSearch As Range
Dim strToFind As String

strToFind = "DRG"
Set wksCurrent = Sheets("Sheet1")
Set rngToSearch = wksCurrent.Columns("C")
Set rngFound = rngToSearch.Find(What:=strToFind, LookAt:=xlWhole)
If rngFound Is Nothing Then
MsgBox "Sorry. Nothing to Move"
Else
Set wksNew = Worksheets.Add
Set rngFirst = rngFound
Set rngAllFound = rngFound.EntireRow
Do
Set rngAllFound = Union(rngAllFound, rngFound.EntireRow)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
rngAllFound.Copy
wksNew.Range("A2").PasteSpecial xlPasteValues
rngAllFound.Delete
wksCurrent.Cells.Copy
wksNew.Cells.PasteSpecial xlPasteFormats
wksCurrent.Rows(1).Copy wksNew.Range("A1")
Application.CutCopyMode = False
End If
End Sub

 

[Jim Thomlinson]

That last bit of code pasted the formats for the entire sheet. This pastes
the formats for only the effected lines...

Sub MoveErrors()
Dim wksCurrent As Worksheet
Dim wksNew As Worksheet
Dim rngFirst As Range
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngToSearch As Range
Dim strToFind As String

strToFind = "DRG"
Set wksCurrent = Sheets("Sheet1")
Set rngToSearch = wksCurrent.Columns("C")
Set rngFound = rngToSearch.Find(What:=strToFind, LookAt:=xlWhole)
If rngFound Is Nothing Then
MsgBox "Sorry. Nothing to Move"
Else
Set wksNew = Worksheets.Add
Set rngFirst = rngFound
Set rngAllFound = rngFound.EntireRow
Do
Set rngAllFound = Union(rngAllFound, rngFound.EntireRow)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
rngAllFound.Copy
wksNew.Range("A2").PasteSpecial xlPasteValues
wksNew.Range("A2").PasteSpecial xlPasteFormats
rngAllFound.Delete
wksCurrent.Rows(1).Copy wksNew.Range("A1")
Application.CutCopyMode = False
End If
End Sub

 

[Lime]

I sorry Jim I ment like if I wanted to pull all the DRG, The kkl, ght, and so
on all at once and move them all at once.

Sorry

 

[Jim Thomlinson]

This code assumes that there is always something in column A of the Rows
being moved. If that is not the case then let me know...

Public Sub MoveAllErrors()
Call MoveErrors("DRG")
Call MoveErrors("ABC")
End Sub

Private Sub MoveErrors(ByVal strToFind As String)
Dim wksCurrent As Worksheet
Dim wksNew As Worksheet
Dim rngFirst As Range
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngToSearch As Range
Dim rngToPaste As Range
Const SHEETNAME As String = "Errors"

Set wksCurrent = Sheets("Sheet1")
Set rngToSearch = wksCurrent.Columns("C")
Set rngFound = rngToSearch.Find(What:=strToFind, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
If SheetExists(SHEETNAME, ThisWorkbook) Then
Set wksNew = Sheets(SHEETNAME)
Else
Set wksNew = Worksheets.Add
wksNew.Name = SHEETNAME
wksCurrent.Rows(1).Copy wksNew.Range("A1")
End If
Set rngFirst = rngFound
Set rngAllFound = rngFound.EntireRow
Do
Set rngAllFound = Union(rngAllFound, rngFound.EntireRow)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
rngAllFound.Copy
Set rngToPaste = wksNew.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
rngToPaste.PasteSpecial xlPasteValues
rngToPaste.PasteSpecial xlPasteFormats
rngAllFound.Delete
wksCurrent.Cells.Copy
Application.CutCopyMode = False
End If
End Sub

Public Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

 

[Lime]

Thank you Jim, am I correct in saying that I would just change the Call
moveErrors("DRG") to what ever I want to move at once??

 

[Lime]

Jim,
What do I need to change to get it to put all the pulls on one sheet
together?

 

[Jim Thomlinson]

It should put all of the moved items onto one sheet named Errors. It will
break down and overwrite values if Column A is not populated on every row
that is being moved...

 

[Lime]

The code is not. Debug at second sheetname???

It should put all of the moved items onto one sheet named Errors. It will
break down and overwrite values if Column A is not populated on every row
that is being moved...