VBA Code to copy different data from one sheet to multiple sheets based on criteria

Hello,

I am very new to VBA code and would greatly appreciate any help you are able to offer. I have a master contacts workbook and would like the ability to add new contacts to sheet 1 and then, based on criteria that was entered in specific columns, have that data automatically be added to the additional appropriate sheets within the workbook. I would like the spreadsheet to auto-update and I would also like for only the first couple of columns for each row to be copied over to additional sheets.

I've attached an example spreadsheet. Eharwood_VBA code sample file.xlsx

I have columns for first name, last name, and contact info. Then there are columns that tag the individual as a member/non-member and based on participation in various committees there is a yes or no for each committee column.

For the first row of my example spreadsheet John Smith is a tagged as a member (per column H) and also a member of the Promotions committee (a yes in column K). Therefore, I would like the ability to have John Smith's information automatically added to the member sheet and also to the promotions sheet. I also only want to copy the info from columns A-G to each additional sheet in the workbook.

Based on extensive googling below is the code that I am attempting to use, but I receive an error message and I also feel like there is a much more efficient way to accomplish the same thing. Any suggestions and help are greatly appreciated!

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim i, LastRow

LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
Sheets("GRMCA Members").Range("A2:G500").ClearContents
For i = 2 To LastRow
If Sheets("Master").Cells(i, "H").Value = "Member" Then
Sheets("Master").Cells(i, "H").EntireRow.Copy Destination:=Sheets("GRMCA Members").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Non-Members").Range("A2:G500").ClearContents
For i = 2 To LastRow
If Sheets("Master").Cells(i, "H").Value = "Non-Member" Then
Sheets("Master").Cells(i, "H").EntireRow.Copy Destination:=Sheets("Non-Members").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
Sheets("EOS").Range("A2:G500").ClearContents
For i = 2 To LastRow
If Sheets("Master").Cells(i, "I").Value = "Yes" Then
Sheets("Master").Cells(i, "I").EntireRow.Copy Destination:=Sheets("EOS").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
Sheets("TAC").Range("A2:G500").ClearContents
For i = 2 To LastRow
If Sheets("Master").Cells(i, "J").Value = "Yes" Then
Sheets("Master").Cells(i, "J").EntireRow.Copy Destination:=Sheets("TAC").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Promotions").Range("A2:G500").ClearContents
For i = 2 To LastRow
If Sheets("Master").Cells(i, "K").Value = "Yes" Then
Sheets("Master").Cells(i, "K").EntireRow.Copy Destination:=Sheets("Promotions").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

LastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Yardage").Range("A2:G500").ClearContents
For i = 2 To LastRow
If Sheets("Master").Cells(i, "L").Value = "Yes" Then
Sheets("Master").Cells(i, "L").EntireRow.Copy Destination:=Sheets("Yardage").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

End Sub

Thank you,

Hi eharwood

Welcome to the Forum!!!

How many members will you have in the Master Sheet?

Hi eharwood

Try the Code in the attached. Please note, I've modified the Sheet Names of GRMCA Member and Non-Member Dropped the trailing "s"). This was done to make the Code less wieldy.

I've also added Data Validation to Columns H through L. CTRL + x will fire the Code.

Option Explicit

Sub Move_Stuff()
  Dim ws As Worksheet
  Dim Rng As Range, cel As Range, cel2 As Range
  Dim LR As Long, LR1 As Long, LR2 As Long
  Dim mySheet As String

  For Each ws In ThisWorkbook.Sheets
    If Not ws.Name = "Master" And Not ws.Name = "Lists" Then
      ws.UsedRange.Offset(1, 0).ClearContents
    End If
  Next ws

  Set ws = Sheets("Master")

  With ws
    LR = .Range("B" & Rows.Count).End(xlUp).Row
    For Each cel In .Range("A2:A" & LR)
      Select Case .Range("H" & cel.Row).Value
      Case "GRMCA Member"
        With Sheets("GRMCA Member")
          LR1 = .Range("B" & Rows.Count).End(xlUp).Row + 1
          .Range(.Cells(LR1, "A"), .Cells(LR1, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value
          Set Rng = ws.Range(ws.Cells(cel.Row, "I"), ws.Cells(cel.Row, "L"))
          For Each cel2 In Rng
            If cel2.Value = "Yes" Then
              mySheet = ws.Cells(1, cel2.Column).Value
              With Sheets(mySheet)
                LR2 = .Range("B" & Rows.Count).End(xlUp).Row + 1
                .Range(.Cells(LR2, "A"), .Cells(LR2, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value
              End With
            End If
          Next cel2
        End With
      Case "Non-Member"
        With Sheets("Non-Member")
          LR1 = .Range("B" & Rows.Count).End(xlUp).Row + 1
          .Range(.Cells(LR1, "A"), .Cells(LR1, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value
          Set Rng = ws.Range(ws.Cells(cel.Row, "I"), ws.Cells(cel.Row, "L"))
          For Each cel2 In Rng
            If cel2.Value = "Yes" Then
              mySheet = ws.Cells(1, cel2.Column).Value
              With Sheets(mySheet)
                LR2 = .Range("B" & Rows.Count).End(xlUp).Row + 1
                .Range(.Cells(LR2, "A"), .Cells(LR2, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value
              End With
            End If
          Next cel2
        End With
      Case Else
        'Do nothing
      End Select
    Next cel
  End With
End Sub

You're welcome...glad I could help.

If you're satisfied by any members response to your issue please use the star icon at the lower left of their post.

Hi eharwood

The Code was written to accommodate the Sample File. I'd need to see what you'd be adding in order to modify the Code for this

If I wanted to add additional sheets or categories to the spreadsheet, how would I alter the code to include the additional tabs

Hi eharwood

If you're simply adding Yes/No questions the change appears rather simple...the new Column Heading needs to be the same as the new Sheet Name...

Option Explicit

Sub Move_Stuff()
  Dim ws As Worksheet
  Dim Rng As Range, cel As Range, cel2 As Range
  Dim LR As Long, LR1 As Long, LR2 As Long
  Dim mySheet As String

  For Each ws In ThisWorkbook.Sheets
    If Not ws.Name = "Master" And Not ws.Name = "Lists" Then
      ws.UsedRange.Offset(1, 0).ClearContents
    End If
  Next ws

  Set ws = Sheets("Master")

  With ws
    LR = .Range("B" & Rows.Count).End(xlUp).Row
    For Each cel In .Range("A2:A" & LR)
      Select Case .Range("H" & cel.Row).Value
      Case "GRMCA Member"
        With Sheets("GRMCA Member")
          LR1 = .Range("B" & Rows.Count).End(xlUp).Row + 1
          .Range(.Cells(LR1, "A"), .Cells(LR1, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value

'############## Change This ###################
          'Set Rng = ws.Range(ws.Cells(cel.Row, "I"), ws.Cells(cel.Row, "L"))
          Set Rng = ws.Range(ws.Cells(cel.Row, "I"), ws.Cells(cel.Row, "M"))
'##############################################

          For Each cel2 In Rng
            If cel2.Value = "Yes" Then
              mySheet = ws.Cells(1, cel2.Column).Value
              With Sheets(mySheet)
                LR2 = .Range("B" & Rows.Count).End(xlUp).Row + 1
                .Range(.Cells(LR2, "A"), .Cells(LR2, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value
              End With
            End If
          Next cel2
        End With
      Case "Non-Member"
        With Sheets("Non-Member")
          LR1 = .Range("B" & Rows.Count).End(xlUp).Row + 1
          .Range(.Cells(LR1, "A"), .Cells(LR1, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value

'############## Change This ###################
          'Set Rng = ws.Range(ws.Cells(cel.Row, "I"), ws.Cells(cel.Row, "L"))
          Set Rng = ws.Range(ws.Cells(cel.Row, "I"), ws.Cells(cel.Row, "M"))
'##############################################

          For Each cel2 In Rng
            If cel2.Value = "Yes" Then
              mySheet = ws.Cells(1, cel2.Column).Value
              With Sheets(mySheet)
                LR2 = .Range("B" & Rows.Count).End(xlUp).Row + 1
                .Range(.Cells(LR2, "A"), .Cells(LR2, "G")).Value = ws.Range("A" & cel.Row).Resize(1, 7).Value
              End With
            End If
          Next cel2
        End With
      Case Else
        'Do nothing
      End Select
    Next cel
  End With
End Sub

You're welcome...glad I could help.

If you're satisfied by any members response to your issue please use the star icon at the lower left of their post.