別のタブにvba固有のテキストコピー

Question

誰かが正しい方向に私を指し示すことができれば、私のコードは完全な行のデータを返しています。私の現在のコード。単語は「OVER」私はそれが例えばサイドバーに情報を返す必要が表示された場合、私は、各行および各列に調べる必要があり

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 

列B各小区分に適用するには、これを必要とします。カラムC- FはG等

Answer 1

これを返す必要があり、列B及びH-Kの数を返す必要がありますか？

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 、繰り返し行をしたいこれを試してみてくださいしていない場合：

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