CODEWITHSUNDEEP
excelvba
Paula
Paula

Reputation: 229

vba specific text copy to another tab

Having issues with some vba, if anyone can point me in the right direction it would be greatly appreciated, currently my code is returning a full row of data and it is returning multiple rows, this is my current code.

    Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet

' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")

j = 3     ' Start copying to row 1 in target sheet
For Each c In Source.Range("G6:K6")   ' Do 50 rows
    If c.Text = "OVER" Then
       Source.Rows(c.Row).Copy Target.Rows(j)
       j = j + 1
    End If
Next c
End Sub

I need to look at each row and in each row if the word "OVER" appears I need it to return the information in the side bar e.g. column B I would need this to apply for each wee section e.g. Column C- F should return the number from column B and H-K should return G etc.

enter image description here

Upvotes: 0

Views: 166

Answers (2)

CMArg
CMArg

Reputation: 1567

This?

Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet

' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")

j = 3     ' Start copying to row 1 in target sheet

For i = 1 To 3 'Number of ¿wees?
    For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(50, 5 * i + 1)) ' Do 50 rows
        If c.Text = "OVER" Then
            Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
           j = j + 1
        End If
    Next c
Next i

End Sub

EDIT If don't want repeated rows, try this one:

Sub BUTTONtest_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet

' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Two Years")
Set Target = ActiveWorkbook.Worksheets("Two Years League")

j = 3     ' Start copying to row 1 in target sheet
a = 1
For i = 1 To 3 'Number of ¿wees?
    For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(50, 5 * i + 1)) ' Do 50 rows
        If c.Text = "OVER" Then
            If a <> c.Row Then
                Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
                j = j + 1
                a = c.Row
            End If
        End If
    Next c
Next i

End Sub

Upvotes: 1

user3598756
user3598756

Reputation: 29421

you could try this code (commented)

Option Explicit

Sub BUTTONtest_Click()
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim iSection As Long
    Dim sectionIniCol As Long, sectionEndCol As Long

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Two Years")
    Set Target = ActiveWorkbook.Worksheets("Two Years League")

    With Source '<--| reference 'Source' sheet
        With .Range("B6:F" & .Cells(.Rows.Count, "B").End(xlUp).row) '<--| reference its columns "B:F" range from row 6 down to last non empty cell in column "B"
            With .Offset(, -1).Resize(, 1) '<--| reference corresponding cells in column "A" (which is an empty column)
                For iSection = 1 To 3 '<-- loop over all your three 5-columns sections
                    sectionIniCol = (iSection - 1) * 5 + 2 '<-- evaluate current section initial col
                    sectionEndCol = sectionIniCol + 4 '<-- evaluate current section ending col
                    .FormulaR1C1 = "=if(countif(RC" & sectionIniCol + 1 & ":RC" & sectionEndCol & ",""OVER"")>0,1,"""")" '<-- write (temporary) formulas in column "A" cells to result "1" should at least one "OVER" occurrence be in corresponding cells of current section columns
                    If WorksheetFunction.Sum(.Cells) > 1 Then Intersect(.Columns(sectionIniCol), .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow).Copy Target.Cells(Target.Rows.Count, 1).End(xlUp).Offset(1) '<-- if any occurrence of "OVER" has been found then copy section initial column cells corresponding to column "A" cells marked with "1" and paste them in from first empty row of 'Target' sheet...
                Next iSection
                .ClearContents '<--| delete (temporary) formulas in target column "A"
            End With
        End With
    End With
End Sub

Upvotes: 1

Related Questions