如果某个范围中的单元格的值为“ x”，则将某个范围的单元格复制并粘贴到另一张工作表中

Question

I am not a programmer by trade but I am trying to automate a small portion of a report I use every day out of curiosity and self interest. Basically, we receive and manually enter contact information (name, e-mail, phone number, etc.) and mark select groups that a person is interested in joining. We then copy and paste that contact information entered into a different sheet for each group.

I want to have a macro that checks the specific columns for each interest group for a "x" and if it finds that value copy and paste the contact information collected to the specific interest groups worksheet. People are able to select multiple interest groups and their contact information is added to each separate interest group spreadsheet.

Report columns look as follows:

Group 1 Group 2 Group 3 Name Organization Phone E-mail  Notes

Row Contact Information looks similar to:
  x  x John ABC Inc. 000-000-0000 john.smith@fake.com  Call me ASAP!

The macro checks the column I have marked interest in Group 1 in and if it finds "x" then it copies the full range to the Group 1 worksheet.

I want it to be able to check multiple columns (ie Group 1, 2, 3) for "x" and then copy and paste the information to the right of those columns to the appropriate sheet for the group. If they have interest in multiple groups, their contact info should be copied to each specific worksheet.\\

Do I need to have separate counters for each group worksheet and is there a way to write a if then statement that checks for x in each of the columns and then runs the appropriate code to copy and paste into that group?

Sub Update()

    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target1 As Worksheet
    Dim Target2 As Worksheet
    Dim Target3 As Worksheet

    Set Source = ActiveWorkbook.Worksheets("Interest Group Tracking")
    Set Target1 = ActiveWorkbook.Worksheets("Group 1")

    j = 1   'Start copying to row 1 in target sheet
    For Each c In Source.Range("A1:A1000") 'not sure if there is a way to not set a limit for the range
        If c = "x" Then
            Source.Rows(c.Row).Copy Target1.Rows(j + 1)
            j = j + 1
            End If
    Next c

End Sub

No errors besides the occasional syntax but don't really know how to structure the loop for checking for each group. I am continuing to research and test things I find and will update if I need to.

Answer 1

See if this helps... I've added comments in the code, but please feel free to ask any other questions:

Sub Update()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim Source As Worksheet: Set Source = wb.Worksheets("Interest Group Tracking")
    Dim Target As Worksheet

    Dim R As Long, C As Long, lRowSrc As Long, lRowDst As Long

    With Source
        lRowSrc = .Cells(.Rows.Count, 1).End(xlUp).Row 'get the last row in your source sheet

        For R = 1 To lRowSrc    'Loop through all rows in the source
            For C = 1 To 3      'Loop through the 3 columns in the source
                If .Cells(R, C) = "x" Then
                    Set Target = wb.Worksheets("Group " & C)    'Assuming all groups have the same names, Group 1, Group 2, etc
                    lRowDst = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row + 1 'get last row + 1 in the target sheet
                    .Rows(R).Copy Target.Rows(lRowDst)
                End If
            Next C
        Next R
    End With

End Sub

EDIT: additional sample

Sub Update()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim Source As Worksheet: Set Source = wb.Worksheets("Interest Group Tracking")
    Dim Target As Worksheet
    Dim shNames() As String: shNames = Split("ABC Group,Voter Accesibility,Animal Rights Activism", ",") 'Add sheet names here in the order of the groups

    Dim R As Long, C As Long, lRowSrc As Long, lColSrc As Long, lRowDst As Long

    With Source
        lRowSrc = .Cells(.Rows.Count, 1).End(xlUp).Row 'get the last row in your source sheet

        For R = 1 To lRowSrc    'Loop through all rows in the source
            For C = 1 To 3      'Loop through the 3 columns in the source
                If .Cells(R, C) = "x" Then
                    Set Target = wb.Worksheets(shNames(C - 1)) 'shNames array starts at 0
                    lRowDst = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row + 1 'get last row + 1 in the target sheet
                    Target.Range(Target.Cells(lRowDst, 1), Target.Cells(lRowDst, 10 - C + 1)) = .Range(.Cells(R, C), .Cells(R, 10)).Value 'allocate the values
                End If
            Next C
        Next R
    End With

End Sub

Answer 2

I changed the main piece of logic at the end but this should work. Instead of copy and pasting, I just made the range in the group1 sheet equal to the row's range. I also use the last used row.

Sub Update()
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim Source As Worksheet
Dim Target1 As Worksheet
Dim Target2 As Worksheet
Dim Target3 As Worksheet
Dim curSheet As Worksheet
Dim lastRow, lastRow1, lastRow2, lastRow3, lastCol As Long
Dim group1, group2, group3, curGroup As Long

Set Source = ActiveWorkbook.Worksheets("Interest Group Tracking")
Set Target1 = ActiveWorkbook.Worksheets("Group 1")
Set Target2 = ActiveWorkbook.Worksheets("Group 2")
Set Target3 = ActiveWorkbook.Worksheets("Group 3")

j = 1   
group1 = 1
group2 = 1
group3 = 1
With Source
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
lastRow3 = .Cells(.Rows.Count, 3).End(xlUp).Row

    If lastRow1 > lastRow2 And lastRow1 > lastRow3 Then
    lastRow = lastRow1
End If
If lastRow2 > lastRow1 And lastRow2 > lastRow3 Then
    lastRow = lastRow2
End If
If lastRow3 > lastRow1 And lastRow3 > lastRow2 Then
    lastRow = lastRow3
End If

For j = 1 To lastRow
    For k = 1 To 3
        If .Cells(j, k) = "x" Then
           Set curSheet = ActiveWorkbook.Sheets("Group" & " " & k)
           If k = 1 Then
                curGroup = group1
           ElseIf k = 2 Then
                curGroup = group2
           ElseIf k = 3 Then
                curGroup = group3
           Else
                GoTo line1
           End If
           curSheet.Range(curSheet.Cells(curGroup, 1), curSheet.Cells(curGroup, lastCol)).Value = .Range(.Cells(j, 1), .Cells(j, lastCol)).Value
        End If
           If k = 1 Then
                group1 = group1 + 1
           ElseIf k = 2 Then
                group2 = group2 + 1
           ElseIf k = 3 Then
                group3 = group3 + 1
           End If
 line1:
    Next k
Next j
End With
 End Sub

Answer 3

Another way of doing it.

Option Explicit

Sub CopyData()

Dim srcWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant

Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Dim LCol As Long

Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet

srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
'loop through column 1 to 3
For i = 1 To 3
    For j = 2 To srcLRow
        'loop through rows

            If srcWS.Cells(j, i).value = "x" Then
                Set destWS = srcWB.Sheets("Sheet" & i)
                destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
                LCol = srcWS.Cells(j, srcWS.Columns.Count).End(xlToLeft).Column 'if you need to grab last used column

                ' Copy data
                Set CopyRange = srcWS.Range(Cells(j, 1), Cells(j, LCol))
                    CopyRange.Copy
                ' paste data from one sht to another
                destWS.Cells(destLRow + 1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=False
                Application.CutCopyMode = False
            End If
    Next j
Next i
MsgBox "Process completed!", vbInformation
End Sub