Excel宏：如果列B具有“ X”，则复制整行并粘贴到名为“列B”的工作表中

Question

我在编写宏方面经验有限，我正在寻找更新工作中使用的当前电子表格的方法。 当前，我们在复制某些母版中的“ X”以删除母版工作表上的其他行之前，复制整个母版工作表并将其粘贴到其他工作表中。

我想做的是搜索主表，如果B列有一个“ X”，则复制整个行并将其粘贴到一个名为“ B列”的工作表中。 然后，一旦B列完成并粘贴，它将查看D列。如果D列具有“ X”，它将复制整行并将其粘贴到名为“ D列”的工作表选项卡中。

提前致谢！

Answer 1

方法

我应该将其包含在我的答案的第一个版本中。

我的解决方案取决于自动筛选。 我首先提供一种播放解决方案，该解决方案通过以下方式演示了此方法：

1. 使B列中不包含X的行不可见
2. 使D列中不包含X的行不可见
3. 清除自动筛选

如果这种方法很吸引人，请您参考我对另一个问题的回答，该问题将创建一个菜单，以便用户可以选择所需的过滤器。

如果这种方法不受欢迎，我提供第二种解决方案，其中涉及将每个过滤器剩余的可见行复制到其他工作表。

介绍

您说“我对编写宏的经验有限”，我指您有一定的经验。 我希望我的解释水平正确。 如有必要，请提问。

我假设您的工作簿在服务器上。 我假设某人具有写权限来更新主工作表，而其他人则打开只读副本，以便他们可以查看他们感兴趣的子集。 如果我的假设是正确的，请拿一份工作簿供您使用。 不用担心其他人会更新工作簿的主版本，我们将在完成后从您的播放版本中复制代码的最终版本。

第1步

将第一段代码复制到播放版本中的模块。 在底部附近，您会发现Const WShtMastName As String = "SubSheetSrc" 。 用主工作表的名称替换SubSheetSrc。

注意：此块中的宏名为CtrlCreateSubSheetB和CreateSubSheetB因为它们是播放版本。 实际版本名为CtrlCreateSubSheet和CreateSubSheet 。

运行宏CtrlCreateSubSheetB 。 您将看到“主”工作表，但仅在B列中带有“ X”的行。单击消息框。您将看到“主”工作表，但仅在D列中具有那些“ X”的行。单击消息框，然后过滤器将消失。 如果您还不存在，请切换到VB编辑器。 在立即窗口中（如果看不到，请单击Ctrl + G ），您将看到类似以下内容的内容：

Rows with X in column 2: $A$1:$G$2,$A$4:$G$5,$A$8:$G$9,$A$11:$G$12,$A$14:$G$14, ...
Rows with X in column 4: $A$1:$G$1,$A$3:$G$3,$A$5:$G$5,$A$7:$G$7,$A$10:$G$10, ...

现在处理宏CtrlCreateSubSheetB和CreateSubSheetB 。 您必须了解这些宏如何产生您所看到的效果。 如有必要，请使用VB帮助，调试器和F8降低宏以标识每个语句在做什么。 我相信我已经为您提供了足够的信息，但如有必要，请再提出问题。

' Option Explicit means I have to declare every variable.  It stops
' spelling mistakes being taken as declarations of new variables.
Option Explicit

' Specify a subroutine with two parameters
Sub CreateSubSheetB(ByVal WShtSrcName As String, ByVal ColSrc As Long)

  ' This macro applies an AutoFilter based on column ColSrc
  ' to the worksheet named WShtSrcName

  Dim RngVis As Range

  With Sheets(WShtSrcName)
    If .AutoFilterMode Then
      ' AutoFilter is on.  Cancel current selection before applying
      ' new one because criteria are additive.
      .AutoFilterMode = False
    End If

    ' Make all rows which do not have an X in column ColSrc invisible
    .Cells.AutoFilter Field:=ColSrc, Criteria1:="X"

    ' Set the range RngVis to the union of all visible rows
    Set RngVis = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)

  End With

  ' Output a string to the Immediate window.
  Debug.Print "Rows with X in column " & ColSrc & ": " & RngVis.Address

End Sub

' A macro to call CreateSubSheetB for different columns
Sub CtrlCreateSubSheetB()

  Const WShtMastName As String = "SubSheetSrc"

  Dim WShtOrigName As String

  ' Save the active worksheet
  WShtOrigName = ActiveSheet.Name

  ' Make the master sheet active if it is not already active so
  ' you can see the different filtered as they are created.
  If WShtOrigName <> WShtMastName Then
    Sheets(WShtMastName).Activate
  End If

  ' Call CreateSubSheet for column 2 (=B) then column 4 (=D)

  Call CreateSubSheetB(WShtMastName, 2)
  Call MsgBox("Click to continue", vbOKOnly)
  Call CreateSubSheetB(WShtMastName, 4)
  Call MsgBox("Click to continue", vbOKOnly)
  With Sheets(WShtMastName)
    If .AutoFilterMode Then
      .AutoFilterMode = False
    End If
  End With

  ' Restore the original worksheet if necessary
  If WShtOrigName <> WShtMastName Then
    Sheets(WShtOrigName).Activate
  End If

End Sub

第2步

如果我对您如何使用工作簿的假设是正确的，则可能不需要太多。 如果John和Mary各自打开了主工作簿的只读副本，则John可以使用B过滤器，而Mary使用D过滤器。 如果这听起来很有趣，请看一下我的答案， 根据其他单元格中的值将行数据从一张纸复制到一张或多张纸上 。

第三步

如果您不喜欢仅使用过滤器的想法，而仍然想创建B数据和D数据的副本，则需要以下代码。

该块中的宏名为CtrlCreateSubSheet和CreateSubSheet但与上面的B版本没有太大区别。

在CtrlCreateSubSheet您需要用这些工作表的名称替换“ SubSheetSrc”，“ SubSheetB”和“ SubSheetD”。 为任何其他控件列添加对CreateSubSheet进一步调用。

注意：这些版本删除目标表的原始内容，尽管这不是您所要求的。 我删除了原始内容，因为（1）您添加新行的内容更加复杂，并且（2）我认为您不正确。 如果您要求的内容有意义，请回来，我将更新代码。

Option Explicit
Sub CtrlCreateSubSheet()

  Const WShtMastName As String = "SubSheetSrc"

  ' Call CreateSubSheet for column 2 (=B) then column 4 (=D)

  Application.ScreenUpdating = False

  Call CreateSubSheet(WShtMastName, 2, "SubSheetB")
  Call CreateSubSheet(WShtMastName, 4, "SubSheetD")
  With Sheets(WShtMastName)
    If .AutoFilterMode Then
      .AutoFilterMode = False
    End If
  End With

  Application.ScreenUpdating = True

End Sub
Sub CreateSubSheet(ByVal WShtSrcName As String, ByVal ColSrc As Long, _
                    ByVal WShtDestName As String)

  ' This macro applies an AutoFilter based on column ColSrc to the worksheet
  ' named WShtSrcName. It then copies the visible rows to the worksheet
  ' named WShtDestName

  Dim RngVis As Range
  Dim WShtOrigName As String

  With Sheets(WShtSrcName)
    If .AutoFilterMode Then
      ' AutoFilter is on.  Cancel current selection before applying
      ' new one because criteria are additive.
      .AutoFilterMode = False
    End If

    ' Make all rows which do not have an X in column ColSrc invisible
    .Cells.AutoFilter Field:=ColSrc, Criteria1:="X"

    ' Set the range RngVis to the union of all visible cells
    Set RngVis = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)

  End With

  If RngVis Is Nothing Then
    ' There are no visible rows.  Since the header row will be visible even if
    ' there are no Xs in column ColSrc, I do not believe this block can
    ' be reached but better to be safe than sorry.
    Call MsgBox("There are no rows with an X in column " & ColSrc, vbOKOnly)
    Exit Sub
  End If

  ' Copy visible rows to worksheet named WShtDestName

  With Sheets(WShtDestName)

    ' First clear current contents of worksheet named WShtDestName
    .Cells.EntireRow.Delete

    ' Copy column widths to destination sheets
    Sheets(WShtSrcName).Rows(1).Copy
    .Rows(1).PasteSpecial Paste:=xlPasteColumnWidths

    ' I do not recall using SpecialPaste column widths before and it did not
    ' work as I expected.  Hunting around the internet I found a link to a   
    ' Microsoft page which gives a workaround.  This workaround worked in
    ' that it copied the column widths but it left row 1 selected.  I have
    ' added the following code partly because I like using FreezePanes and
    ' partly to unselect row 1.
    WShtOrigName = ActiveSheet.Name
    If WShtOrigName <> WShtDestName Then
      .Activate
    End If
    .Range("A2").Select
    ActiveWindow.FreezePanes = True
    If WShtOrigName <> WShtDestName Then
      Sheets(WShtOrigName).Activate
    End If

    ' Copy all the visible rows in the Master sheet to the destination sheet. 
    RngVis.Copy Destination:=.Range("A1")

  End With

End Sub

第四步

对宏进行去水平处理后，您需要将包含宏的模块从播放版本复制到主版本。 您可以先导出模块，然后再导入模块，但是我认为以下操作更容易：

• 打开工作簿的播放版和母版。
• 在主版本中创建一个空模块来保存宏。
• 在播放版本中选择宏，将其复制到暂存器，然后将其粘贴到主版本的空模块中。

您将需要教谁负责更新主版本的人员，以便在重大更新完成时运行宏。 您可以使用快捷键或将宏添加到工具栏，以使宏易于使​​用。

摘要

希望所有这些都有意义。 如有必要，请提问。

Answer 2

更简单地说：

Sub Columns()
    If WorkSheets("Sheet1").Range("B1") = x Then
        WorkSheets("Column B").Range("B2") = WorkSheets("Sheet1").Range("B2:B" & Rows.Count).End(xlup).Row
    End if
    If WorkSheets("Sheet1").Range("D1") = x Then
        WorkSheets("Column D").Range("D2") = WorkSheets("Sheet1").Range("D2:D" & Rows.Count).End(xlup).Row
    End if
End Sub