Need loop to cut rows that meet criteria and paste to another sheet.

25 pts.
Tags:
Microsoft Excel
Microsoft Excel 2003
Microsoft Excel macros
VBA
I want a loop that will look at the first four words in column A and if they match then the entire row should be cut and pasted to another sheet.

Software/Hardware used:
2003 Excel

Answer Wiki

Thanks. We'll let you know when a new response is added.

If the first 4 words match what? is it the first 4 words match the first 4 words of the row below or just all of the first 4 words are the same?

Discuss This Question: 4  Replies

 
There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when members answer or reply to this question.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
  • Mdsc
    If the first four words match the first four wordsof the row below. Thanks, MDS
    25 pointsBadges:
    report
  • Darraca
    try this:
    Option Explicit
    
    Private Sub CheckRows()
    
        Dim sCurrentText As String
        Dim sPreviousText As String
        Dim Counter As Long
        
        On Error GoTo ErrHandler
        
        Range("A1").Select
        Counter = 2
        Do Until ActiveCell.Text = ""
            sPreviousText = FirstFourWords(Trim(Range("A" & Counter - 1)))
            sCurrentText = FirstFourWords(Trim(Range("A" & Counter)))
            If Not sCurrentText = "NOT LONG ENOUGH" Then
                If sCurrentText = sPreviousText Then
                    CutRowToNextSheet (Counter)
                    Counter = Counter - 1
                End If
            End If
            Counter = Counter + 1
            ActiveCell.Offset(1, 0).Activate
        Loop
            
    Finish:
        On Error GoTo 0
        Exit Sub
    ErrHandler:
        MsgBox "Error: " & Err.Description & " (" & Err.Number & ")"
        Resume Finish
        Resume
    End Sub
    
    Private Function FirstFourWords(sCellText As String) As String
        
        Dim iCounter As Integer
        Dim iSpaces As Integer
        On Error GoTo ErrHandler
        
        iSpaces = 0
        
        If sCellText = "" Then
            FirstFourWords = "NO TEXT"
            GoTo Finish
        End If
        
        For iCounter = 1 To Len(sCellText)
            If Mid(sCellText, iCounter, 1) = " " Then
                iSpaces = iSpaces + 1
                If iSpaces = 4 Then
                    FirstFourWords = Trim(Left(sCellText, iCounter - 1))
                    Exit For
                End If
            End If
            FirstFourWords = "NOT LONG ENOUGH"
        Next iCounter
        
    Finish:
        On Error GoTo 0
        Exit Function
    ErrHandler:
        MsgBox "Error: " & Err.Description & " (" & Err.Number & ")"
        Resume Finish
        Resume
    End Function
    
    Private Sub CutRowToNextSheet(ByVal RowNumber As Integer)
        On Error GoTo ErrH
            
        Rows(RowNumber).Select
        Selection.Cut
        Sheets("Sheet2").Select
        Sheets("Sheet2").Range("A1").Select
        Do Until ActiveCell.Text = ""
            ActiveCell.Offset(1, 0).Activate
        Loop
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Selection.Delete Shift:=xlUp
        
    Finish:
        On Error GoTo 0
        Exit Sub
    ErrHandler:
        MsgBox "Error: " & Err.Description & " (" & Err.Number & ")"
        Resume Finish
        Resume
    End Sub
    
    290 pointsBadges:
    report
  • Mdsc
    That worked great, thanks for your help. MDS
    25 pointsBadges:
    report
  • Darraca
    No problem, glad it helped :)
    290 pointsBadges:
    report

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to:

To follow this tag...

There was an error processing your information. Please try again later.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy

Thanks! We'll email you when relevant content is added and updated.

Following