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

Question

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

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

在此先感谢！

Answer 1

方法

我应该在我的回答的第一个版本包括在此。

我的解决方案取决于AutoFilter。我第一次报价，通过展示这种方法的即插即用解决方案：

1. 使不含有B列中的无形X行
2. 使不包含在列d无形
3. X行清除自动筛选

如果这种方法很吸引人，我把你的答案转给另一个创建菜单的问题，以便用户可以选择他们想要的过滤器。

如果这种方法没有吸引力，我提供第二个解决方案，它将每个过滤器左侧的可见行复制到其他工作表。

介绍

你说“我有限的经验编写宏的”，我采取的意思是你有一些经验。我希望我的解释水平正确。如果有必要，请回答问题。

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

步骤1

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

注意：此块内的宏被命名为CtrlCreateSubSheetB和CreateSubSheetB，因为它们是播放版本。真正的版本被命名为CtrlCreateSubSheet和CreateSubSheet。

运行宏CtrlCreateSubSheetB。您将看到Master工作表，但只看到B列中带有“X”的那些行。单击消息框。您将看到Master工作表，但只会看到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

一旦deleveloped宏让您满意，您将需要包含宏的模块从你的游戏版本复制到主版本。您可以导出模块，然后导入它，但我认为以下更容易：

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

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

摘要

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

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