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