vba特定文本副本到另一个标签

Question

遇到一些vba的问题，如果有人能指出我正确的方向，我将非常感激，目前我的代码返回一整行数据并返回多行，这是我当前的代码。

    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

我需要查看每一行和每行中是否出现“OVER”字样我需要它来返回侧栏中的信息，例如B栏我需要这个申请每个部分，例如C-F栏应该从B栏返回数字，H-K应该返回G等。

Answer 1

此？

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

修改 如果不想重复行，请尝试以下方法：

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

Answer 2

你可以试试这段代码（评论）

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