Question

我正在编写代码以查找特定的关键字（“团队”），找到后，我要将团队名称粘贴到上面所有行的特定列（“ D”）中。如果找不到关键字，我想复制整行。所有这些都粘贴到新的工作表中。

我所拥有的：

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

团队A ---- x ------------ x

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

B队------ x ------------- x

我想要什么：

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

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

如果满足条件，如何在特定列的上方行中存储文本和发布？

1 个答案: