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

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

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

提前致谢！

Answer 1

途径

我应该在我的答案的第一个版本中包括这个。

我的解决scheme取决于AutoFilter。 我首先提供一个演示解决scheme来演示这种方法：

1. 使列B中不包含X的行不可见
2. 使D列中不包含X的行不可见
3. 清除AutoFilter

如果这种方法有吸引力，那么我把你的答案提交给另一个创build菜单的问题，以便用户可以select他们想要的filter。

如果这种方法没有吸引力，我提供了第二个解决scheme，其中包括将每个filter左侧的可见行复制到其他工作表。

介绍

你说“我有限的编写macros的经验”，我认为你有一些经验。 我希望我的解释水平是正确的。 如果有必要回来的问题。

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

步骤1

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

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

运行macrosCtrlCreateSubSheetB 。 您将看到主工作表，但只有在B列中具有“X”的那些行。单击消息框。您将看到主工作表，但只有那些在D列中具有“X”的行。单击消息框并单击filter将消失。 如果你不在那里，切换到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, ... 

现在处理macrosCtrlCreateSubSheetB和CreateSubSheetB 。 你必须了解这些macros如何创造你看到的效果。 如有必要，使用VB帮助，debugging器和F8降低macros，以确定每个语句正在做什么。 我相信我已经给了你足够的信息，但如果有必要的话还会回来提问。

 ' 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可以使用Bfilter，而Mary使用Dfilter。 如果这听起来很有趣，看看我的答案， 从一张纸复制行数据到一张或多张基于其他单元格中的值 。

第3步

如果您不喜欢使用filter的想法，并且仍想创buildB数据和D数据的副本，则需要下面的代码。

这个块内的macros被命名为CtrlCreateSubSheet和CreateSubSheet但是与上面的B版本没有太大的区别。

在CtrlCreateSubSheet您将需要用这些工作表的名称replace“SubSheetSrc”，“SubSheetB”和“SubSheetD”。 进一步调用CreateSubSheet进一步控制列。

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

一旦你完成macros的开发，你将需要将包含macros的模块从播放版本复制到主版本。 您可以导出模块，然后导入它，但我认为以下更容易：

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

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

概要

希望一切都有道理。 如有必要，请提问。

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