Move EntireRow below Table1 if range in table contains specific word

[chriskay]

Hi all :-)

I am completely clueless on how to do this one (my VBA skills are very limited)… For the attached sheet, I need a vba script that checks Range("B") inside "Table1" for any cells with the word "TEST", and IF (the word isn't always there) that specific word is there, then move the entire row of that cell below the table and create and add to a "Table2", and hereby exclude the "test"-row from Table1.

If any help, the layout of Table1 is "fixed", and will always start with headers in A7:I7, but the length of the data is variable. Also, there will always be a number in A to the data.

On the first row below Table1 - and also the first row below the newly created Table2 (if it is created), there must be a SUM([Field 1]), SUM([Field 2]) and SUM([FIELD 3])

I attached two sheets, one with the basic data and one that looks like it is supposed to, after the VBA :-)

I know it might sound confusing, so please just ask if anything :-)

[Sintek]

Would be so much simpler if another sheet was used...But anyway...perhaps someone else can simplify...

Please Login or Register  to view this content.

[Metoo7]

Please Login or Register  to view this content.

[Marc L]

I am completely clueless on how to do this one (my VBA skills are very limited)…

As any beginner can start to activate the Macro Recorder and operate manually Excel basics
then just comparing the generated code with the operations and reading the VBA help, a good way for learning …


According to your attachment a VBA beginner starter covering both cases and avoiding some issues :

Sub Demo1()
         Dim V, R&
    With Me.ListObjects
        If .Count = 0 Then Beep: Exit Sub
        If .Item(1).ListRows.Count = 0 Then Beep: Exit Sub
        V = Me.Evaluate("IF({1},ISNUMBER(SEARCH(""test""," & .Item(1).DataBodyRange.Columns(2).Address & ")))")
        If IsError(Application.Match(True, V, 0)) Then Beep: Exit Sub
        Application.ScreenUpdating = False
    For R = 1 To .Count
        If .Item(R).AutoFilter.FilterMode Then .Item(R).Range(1).Select: Me.ShowAllData
    Next
    If .Count = 1 Then
           .Item(1).Range.Copy Me.UsedRange.Rows(Me.UsedRange.Rows.Count).Cells(4, .Item(1).Range.Column)
        For R = UBound(V) To 1 Step -1
            If Not V(R, 1) Then .Item(2).ListRows(R).Delete
        Next
    Else
           .Item(2).ShowTotals = False
        For R = 1 To UBound(V)
            If V(R, 1) Then .Item(1).ListRows(R).Range.Copy .Item(2).ListColumns(1).Range(.Item(2).ListRows.Count + 2)
        Next
           .Item(2).ShowTotals = True
    End If
    For R = UBound(V) To 1 Step -1
        If V(R, 1) Then .Item(1).ListRows(R).Delete
    Next
        Application.ScreenUpdating = True
    End With
End Sub 

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[Marc L]

I forgot to mention : previous post code must be pasted to the Ark1 worksheet module …

[Sintek]

slight simplification...

Please Login or Register  to view this content.