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

Macro for Excel: If Column B has "X", then copy entire row and paste in Worksheet named "Column B"

提问by Mark Berlin

I have limited experienced of writing macros, and I'm looking to update a current spreadsheet used at work. Currently we copy the entire Master worksheet and paste it into other worksheets before sorting for the "X" in certain columns to delete other rows on the master worksheet.

我编写宏的经验有限，我希望更新工作中使用的当前电子表格。目前我们复制整个主工作表并将其粘贴到其他工作表中，然后在某些列中对“X”进行排序以删除主工作表上的其他行。

What I am looking to do is search the Master Sheet, and if Column B has an "X" then copy the entire row and paste it into a worksheet named "Column B". Then, once Column B was completed and pasted, it would look at Column D. If Column D had an "X", it would copy the entire row and paste it in worksheet tab named "Column D".

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

Thanks in advance!

提前致谢！

回答by Tony Dallimore

Approach

方法

I should have included this in the first version of my answer.

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

My solution depends on AutoFilter. I first offer a play solution that demonstrates this approach by:

我的解决方案取决于 AutoFilter。我首先提供一个播放解决方案，通过以下方式演示这种方法：

1. making rows not containing X in column B invisible
2. making rows not containing X in column D invisible
3. clearing the AutoFilter

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

If this approach appeals, I refer you to my answer to another question which creates a menu so the user can select which filter they want.

如果这种方法有吸引力，我会向您推荐我对另一个问题的回答，该问题创建了一个菜单，以便用户可以选择他们想要的过滤器。

If this approach does not appeal, I offer a second solution which involves copying the visible rows left by each filter to other worksheets.

如果这种方法不吸引人，我提供了第二种解决方案，包括将每个过滤器留下的可见行复制到其他工作表。

Introduction

介绍

You say "I have limited experienced of writing macros" which I take to mean you have some experience. I hope I have the level of explanations correct. Come back with questions if necessary.

您说“我编写宏的经验有限”，我认为这意味着您有一些经验。我希望我的解释水平是正确的。如有必要，请回来提出问题。

I assume your workbook is on a server. I assume someone has write access to update the master worksheet while others open read-only copies so they can look at the subsets of interest to them. If my assumptions are about right, take a copy of the workbook for you to play with. Don't worry about others updating the master version of the workbook, we will copy the final version of the code from your play version when we have finished.

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

Step 1

第1步

Copy the first block of code to a module within the play version. Near the bottom you will find Const WShtMastName As String = "SubSheetSrc". Replace SubSheetSrc by the name of your master worksheet.

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

Note: the macros within this block are named CtrlCreateSubSheetBand CreateSubSheetBbecause they are play versions. The real versions are named CtrlCreateSubSheetand CreateSubSheet.

注意：这个块中的宏被命名CtrlCreateSubSheetB，CreateSubSheetB因为它们是播放版本。真实版本名为CtrlCreateSubSheet和CreateSubSheet。

Run macro CtrlCreateSubSheetB. You will see the Master worksheet but only those rows with an "X" in column B. Click on the message box.You will see the Master worksheet but only those rows with an "X" in column D. Click on the message box and the filter will disappear. Switch to the VB Editor if you are not already there. In the Immediate Window (Click Ctrl+Gif it is not visible) and you will see something like:

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

Rows with X in column 2: $A:$G,$A:$G,$A:$G,$A:$G,$A:$G, ...
Rows with X in column 4: $A:$G,$A:$G,$A:$G,$A:$G,$A:$G, ...

Now work down macros CtrlCreateSubSheetBand CreateSubSheetB. You must understand how these macro have created the effects you saw. If necessary use VB Help, the Debugger and F8to step down the macros to identify what each statement is doing. I believe I have given you enough information but come back with questions if necessary.

现在处理宏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

Step 2

第2步

If my assumptions about how you use the workbook are correct you may not need much more. If John and Mary each open a read-open copy of the master workbook then John could use the B filter while Mary uses the D filter. If this sounds interesting, look at my answer to copy row data from one sheet to one or more sheets based on values in other cells.

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

Step 3

第 3 步

If you do not like the idea of just using filters and still want to create copies of the B data and the D data, you will need the code below.

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

The macros within this block are named CtrlCreateSubSheetand CreateSubSheetbut are not much different from the B versions above.

此块中的宏已命名CtrlCreateSubSheet，CreateSubSheet但与上面的 B 版本没有太大区别。

In CtrlCreateSubSheetyou will need to replace "SubSheetSrc", "SubSheetB" and "SubSheetD" with your names for these worksheets. Add further calls of CreateSubSheetfor any further control columns.

在CtrlCreateSubSheet你需要与你的名字，这些工作表来代替“SubSheetSrc”，“SubSheetB”和“SubSheetD”。CreateSubSheet为任何进一步的控制列添加进一步的调用。

Note: these version delete the original contents of the destination sheets although this is not what you have asked for. I have deleted the original contents because (1) what you have adding new rows is more complicated and (2) I do not believe you are correct. If there is some significance to what you requested then come back and I will update the code.

注意：这些版本删除了目标工作表的原始内容，尽管这不是您所要求的。我删除了原始内容，因为（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

Step 4

第四步

Once you have deleveloped the macros to your satisfaction, you will need to copy the module containing the macros from your play version to the master version. You can export the module and then import it but I think the following is easier:

一旦您将宏降级到您满意的程度，您将需要将包含宏的模块从您的播放版本复制到主版本。您可以导出模块然后导入它，但我认为以下更容易：

• Have both the play and master versions of the workbook open.
• Create an empty module in the master version to hold the macros.
• Select the macros in the play version, copy them to the scratchpad and then paste them to the empty module in the master version.

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

You will need to teach whoever is responsible for updating the master version to run the macros whenever a significant update is complete. You could use a shortcut key or add the macro to the toolbar to make the macro easy to use.

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

Summary

概括

Hope all that makes sense. Do ask questions if necessary.

希望一切都有意义。如有必要，请提出问题。

回答by artis_meditari

More simply:

更简单：

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