Как сохранить текст и пост в вышеупомянутых строках в определенном столбце, если условие выполнено?

Question

Я пишу код для поиска определенного ключевого слова («Команда»), и, когда он будет найден, я хочу вставить название команды в определенный столбец («D») для всех строк выше.Если ключевое слово не найдено, я хочу скопировать всю строку.Все это вставлено в новый лист.

Что у меня есть:

x ------------- x ------------x

x ------------- x ------------ x

Команда A ---- x------------ x

x ------------- x ------------- x

x ------------- x ------------- x

Команда B ---- x ------------- x

Что я хочу:

x ---- x ---- x ---- A

x----x ---- x ---- A

x ---- x ---- x ---- B

x ---- x ----x ---- B

Вот что у меня есть:

Sub fun()
  Dim j as Integer
  Dim lastrow as Integer
  Dim team as String
  Dim sh As Worksheet

  sh = Sheets("Sheet 1")
  lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlup).Row
  Range("A" & lastrow).Select

  for j = 1 to lastrow

    If Instr(Cells(j,1).Value, "Team") Then
        Cells(j,1).Value = Replace(Cells(j,1).Value, "Team ", "")
        Cells(j,1).Value = team
    Else
        Range(Cells(j,1), Cells(j,3). Select
        Selection.Copy

        Windows("sheet.xlsm").Activate
        ActiveSheet.Cells(1,1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
    End If

  next j

End Sub

Я могу выполнить второе условие и вставить целые строки, но не знаю, как копироватьимена команд и разместите их в столбце D на новом листе.

Answer 1

Примерно так:

Sub fun()

  Dim j As Long, destRow As Long
  Dim team As String, v, rngTeam As Range
  Dim sh As Worksheet, shDest As Worksheet

  Set sh = Sheets("Sheet1")
  Set shDest = Sheets("Sheet2") 'for example
  destRow = shDest.Cells(Rows.Count, 1).End(xlUp).Row + 1

  For j = 1 To sh.Cells(Rows.Count, 1).End(xlUp).Row
    v = sh.Cells(j, 1).Value
    If InStr(v, "Team") > 0 Then
        If Not rngTeam Is Nothing Then rngTeam.Value = Replace(v, "Team ", "") '<< set for already-copied rows
        Set rngTeam = Nothing 'reset the range
    Else
        shDest.Cells(destRow, 1).Resize(1, 3).Value = sh.Cells(j, 1).Resize(1, 3).Value
        'add to the range to populate next time we hit a "Team"
        If rngTeam Is Nothing Then
            Set rngTeam = shDest.Cells(destRow, 4)
        Else
            Set rngTeam = Application.Union(shDest.Cells(destRow, 4), rngTeam)
        End If
        destRow = destRow + 1
    End If

  Next j

End Sub