我编写宏的经验有限，我希望更新当前使用的电子表格。目前，我们复制整个Master工作表并将其粘贴到其他工作表中，然后在某些列中排序“X”以删除主工作表上的其他行。
我要做的是搜索主表，如果列B有“X”，则复制整行并将其粘贴到名为“B列”的工作表中。然后，一旦完成并粘贴了B列，它将查看D列。如果D列有一个“X”，它将复制整行并将其粘贴到名为“D列”的工作表标签中。
提前致谢！
答案 0 :(得分：1)
<强>方法
我应该在我的答案的第一个版本中包含这个。
我的解决方案取决于AutoFilter。我首先提供一种演示解决方案，通过以下方式演示此方法：
如果这种方法有吸引力，我建议您回答另一个创建菜单的问题的答案，以便用户可以选择他们想要的过滤器。
如果这种方法没有吸引力，我提供了第二种解决方案，涉及将每个过滤器留下的可见行复制到其他工作表。
<强>简介
你说“我的写作经验有限”，我认为你有一些经验。我希望我的解释水平正确。如有必要，请回答问题。
我假设您的工作簿在服务器上。我假设某人有写入权限来更新主工作表，而其他人则打开只读副本，这样他们就可以查看他们感兴趣的子集。如果我的假设是正确的，请拿一份工作簿供您使用。不要担心其他人更新工作簿的主版本，我们将在完成后从您的播放版本中复制最终版本的代码。
第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过滤器。如果这听起来很有意思，请查看我对copy row data from one sheet to one or more sheets based on values in other cells的回答。
第3步
如果您不喜欢仅使用过滤器并且仍想创建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
第4步
一旦您满意地删除了宏，就需要将包含宏的模块从播放版本复制到主版本。您可以导出模块然后导入它，但我认为以下更容易：
每当重要更新完成时，您将需要教授负责更新主版本的人员以运行宏。您可以使用快捷键或将宏添加到工具栏中以使宏易于使用。
<强>摘要
希望所有这些都有意义。如有必要，请提出问题。
答案 1 :(得分：0)
更简单：
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