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

Question

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.

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".

Thanks in advance!

Answer 1

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:

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

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

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.

Note: the macros within this block are named CtrlCreateSubSheetB and CreateSubSheetB because they are play versions. The real versions are named CtrlCreateSubSheet and 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 + G if it is not visible) and you will see something like:

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, ...

Now work down macros CtrlCreateSubSheetB and CreateSubSheetB . You must understand how these macro have created the effects you saw. If necessary use VB Help, the Debugger and F8 to 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.

' 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

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 .

Step 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.

The macros within this block are named CtrlCreateSubSheet and CreateSubSheet but are not much different from the B versions above.

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

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.

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.

Answer 2

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