Help - selectively cutting and pasting rows

[shauntwo]

I'm just beginning to appreciate VBA, and had a question to streamline some activities in my new job: I'm working with an Excel spreadsheet, and I want to find all instances of "4101". When I find such an instance, I want to cut the entire row and paste it into an adjacent sheet (i.e. Sheet2). The end result is that Sheet2 lists all records containing "4101", and Sheet1 has no instances or blank lines from the cut and paste job.

Any quick help would be very much appreciated. I'm pleased with the help I've found here so far. Thanks so much.

 

[segmentationfault]

Try this. It can be inserted anywhere in the workbook or in a separate module.

If you have tons of data (10,000 rows or more) and are willing to add a column, or if the order of the rows does not matter, I can probably provide a much faster method.

' The sheet with the source data
Private Const SourceSheet As Byte = 1
' The sheet to which data will be
' pasted
Private Const DestSheet As Byte = 2

Sub CutStuff()
    
    Dim InitialRow As Long
    Dim InitialCol As Long
    Dim FinalRow As Long
    Dim FinalCol As Long
    
    ' The first row you want to search
    InitialRow = 1
    ' The first column you want to search
    InitialCol = 1
    ' The last column you want to search
    FinalCol = 2

    Dim s As String
    ' If always searching for the same
    ' pattern, consider changing the next
    ' line to s = "pattern"
    s = InputBox("Cut which pattern?")
    
    Dim FoundCell As Range
    Dim RowsCut As Long
    Dim BlankRow As Long
    
    Do
        Sheets(SourceSheet).Activate
        FinalRow = Range(Cells(65536, FinalCol), _
            Cells(65536, FinalCol)).End(xlUp).Row
        Range(Cells(InitialRow, InitialCol), _
            Cells(FinalRow, FinalCol)).Select
        Set FoundCell = Selection.Find(what:=s, _
            MatchCase:=True)
        If Not FoundCell Is Nothing Then
            BlankRow = FoundCell.Row
            Rows(FoundCell.Row).Cut
            Sheets(DestSheet).Activate
            Cells(InitialRow + RowsCut, _
                InitialCol).Select
            ActiveSheet.Paste
            RowsCut = RowsCut + 1
            ' Uncomment if you want to remove the
            ' blank row
            ' Sheets(SourceSheet).Activate
            ' Rows(BlankRow).Delete shift:=xlUp
        End If
    Loop While Not FoundCell Is Nothing
End Sub

 

[shauntwo]

segmentationfault, thanks so much for your reply. I've only had a chance to test it out briefly, but it works perfectly. You've saved me countless hours of sifting through books at Barnes & Noble. Maybe your or someone could recommend a book or two, by the way? Thanks again for all your help.

 

[shauntwo]

Well, after some additional troubleshooting, I've observed that this won't catch those instances of "4101" in records if they don't exist at least on the first line. The original code is below, with my changes to sheets... the instances may be in every row, or in one row - it varies. If this code will catch that, what have I modified incorrectly?

Thanks...



' The sheet with the source data
Private Const Sheet1 As Byte = 1
' The sheet to which data will be
' pasted
Private Const Sheet2 As Byte = 2

Sub CutStuff()

Dim InitialRow As Long
Dim InitialCol As Long
Dim FinalRow As Long
Dim FinalCol As Long

' The first row you want to search
InitialRow = 1
' The first column you want to search
InitialCol = 1
' The last column you want to search
FinalCol = 30

Dim s As String
' If always searching for the same
' pattern, consider changing the next
' line to s = "pattern"
s = "4101"

Dim FoundCell As Range
Dim RowsCut As Long
Dim BlankRow As Long

Do
Sheets("Sheet1&quot.Activate
FinalRow = Range(Cells(65536, FinalCol), _
Cells(65536, FinalCol)).End(xlUp).Row
Range(Cells(InitialRow, InitialCol), _
Cells(FinalRow, FinalCol)).Select
Set FoundCell = Selection.Find(what:=s, _
MatchCase:=True)
If Not FoundCell Is Nothing Then
BlankRow = FoundCell.Row
Rows(FoundCell.Row).Cut
Sheets("Sheet2&quot.Activate
Cells(InitialRow + RowsCut, _
InitialCol).Select
ActiveSheet.Paste
RowsCut = RowsCut + 1
' Uncomment if you want to remove the
' blank row
Sheets("Sheet1&quot.Activate
Rows(BlankRow).Delete shift:=xlUp
End If
Loop While Not FoundCell Is Nothing
End Sub

 

[segmentationfault]

I'm afraid that I don't understand your description of the problem. The code I posted should find any instance of s within the range specified by (InitialRow, InitialCol) through (FinalRow, FinalCol) and FinalRow is set to the bottom used cell in FinalCol. Perhaps you could clarify what you mean by "if they don't exist at least on the first line"?

I can point out that you have incorrectly modified the Sheets().Activate lines. Remove the quotation marks so that you are selecting sheets based on the number stored in the Sheet1 and Sheet2 constant. Leaving the quotation marks means that you are literally selecting "Sheet1" and "Sheet2". If the worksheets are renamed, this will not work.

 

[shauntwo]

Well, that may be just it. I will rename the sheets properly and give this another go. Sorry for the delay in responding. I appreciate your reponse, and your help.

Best of luck.

 

[shauntwo]

segmentationfault, I changed my sheets to constants, like your code dictated, but I still ran into the same problem: unless a "4101" exists on every record, it won't be cut and pasted into Sheet2. I read through the code, to learn and understand, and I changed the following line from:

FinalRow = Range(Cells(65536, FinalCol), ...

to: FinalRow = Range(Cells(65536, InitialCol), ...

in essence, basically setting the beginning and end of the row, rather than the end and end. Is my logic correct? So far, this seems to have done the trick. If you can, drop a line and let me know...

 

[bryanbayfield]

More compact and efficient code ...

sub copy_over()
Dim rgFoundCell As Range, n As Integer
Application.ScreenUpdating = False
Set rgFoundCell = Sheets("Sheet1&quot.UsedRange.Find(what:="4101&quot
n = 1
Do Until rgFoundCell Is Nothing
rgFoundCell.EntireRow.Cut Destination:=Sheets("Sheet2&quot.Rows
n = n + 1
Set rgFoundCell = Sheets("Sheet1&quot.UsedRange.FindNext
Loop
end sub

 

[shauntwo]

Bryan,

Thanks for the tip - other than deleting the blank row left from the cut job, that code seems to work pretty slick. I'll play around with it more during the day, but thanks for your help!

 

[dwilson01]

Adding a couple of lines to bryanbayfield's code, this seems to do what you want.

Sub copy_over()

Dim rgFoundCell As Range, n As Integer, DelRow As Integer

Application.ScreenUpdating = False

Set rgFoundCell = Sheets("Sheet1&quot.UsedRange.Find(what:="4101&quot
n = 1
Do Until rgFoundCell Is Nothing
DelRow = rgFoundCell.Row
rgFoundCell.EntireRow.Cut Destination:=Sheets("Sheet2&quot.Rows
Rows(DelRow).Delete Shift:=xlUp
n = n + 1
Set rgFoundCell = Sheets("Sheet1&quot.UsedRange.FindNext
Loop

Application.ScreenUpdating = True

End Sub

Great job Bryan!

 

[shauntwo]

DWilson, clearly I'm a VBA newbie, but your two lines seem pretty intuitive to me. Everybody's suggestions have been greatly appreciated. Thanks to all.

 

[dwilson01]

I was a little bored and this thread really applies to something I am working on, so I tool the libetry of making some more small adjustments. This cose uses an inputbox to get user input for what they want to move from sheet 1 to sheet 2. Also, Sheet 2 is appended, not overwriten, so new data is tacked on to the end of the data already in sheet 2. I have made teh observation that I created a program, with the help of Bryan, the does basically the same thing as the autofilter function in Excel. Anyway, here it is.

Sub copy_over()

Dim rgFoundCell As Range, n As Integer
Dim FindWhat As String, DelRow As Integer

Application.ScreenUpdating = False

FindWhat = InputBox("What would you like to move to Sheet 2 ", "Move Data&quot
Set rgFoundCell = Sheets("Sheet1&quot.UsedRange.Find(What:=FindWhat)
n = 1
Do
DelRow = rgFoundCell.Row
rgFoundCell.EntireRow.Cut Destination:= _
Sheets("Sheet2&quot.Rows(Sheets("Sheet2&quot.UsedRange.Rows.Count + 1)
Rows(DelRow).Delete Shift:=xlUp
n = n + 1
Set rgFoundCell = Sheets("Sheet1&quot.UsedRange.FindNext
Loop Until rgFoundCell Is Nothing

Application.ScreenUpdating = True

MsgBox "Number of instances found " & n - 1

End Sub

Now I am done, sorry for the multiple posts, but the more you play with something, the more you want to share your findings.