Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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?? "Jim Thomlinson" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
Jim,
What do I need to change to get it to put all the pulls on one sheet together? "Lime" wrote: 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?? "Jim Thomlinson" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
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... -- HTH... Jim Thomlinson "Lime" wrote: Jim, What do I need to change to get it to put all the pulls on one sheet together? "Lime" wrote: 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?? "Jim Thomlinson" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
slecting data???
The code is not. Debug at second sheetname???
"Jim Thomlinson" wrote: 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... -- HTH... Jim Thomlinson "Lime" wrote: Jim, What do I need to change to get it to put all the pulls on one sheet together? "Lime" wrote: 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?? "Jim Thomlinson" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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" wrote: 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 -- HTH... Jim Thomlinson "Lime" wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
slecting all entries to appear once | Excel Worksheet Functions | |||
slecting all entries to appear once | Excel Worksheet Functions | |||
Increase Your Business By Data Conversion, Data Format and Data EntryServices in India | Excel Worksheet Functions | |||
Data Entry Online, Data Format, Data Conversion and Data EntryServices through Data Entry Outsourcing | Excel Discussion (Misc queries) | |||
Slecting worksheets one by one.....possible? | Excel Programming |