我不是行业程序员，但出于好奇和自身利益，我试图使我每天使用的一小部分报告自动化。基本上，我们接收并手动输入联系信息（姓名，电子邮件，电话号码等），并标记某人有兴趣加入的选定组。然后，我们将输入的联系信息复制并粘贴到每个组的不同工作表中。
我想拥有一个宏，用于检查每个兴趣组的特定列是否为“ x”，如果它找到该值，则将其复制并将粘贴的联系信息粘贴到特定兴趣组工作表中。人们可以选择多个兴趣组，并将他们的联系信息添加到每个单独的兴趣组电子表格中。
报告列如下：
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!
该宏会检查我在第1组中标记为感兴趣的列，如果找到“ x”，则会将整个范围复制到第1组工作表。
我希望它能够检查“ x”的多个列（即第1、2、3组），然后将这些列右侧的信息复制并粘贴到该组的适当工作表中。如果他们对多个组感兴趣，则应将他们的联系信息复制到每个特定的工作表中。\
每个组工作表是否都需要有单独的计数器，是否可以编写一个if then语句来检查每个列中的x，然后运行适当的代码来复制并粘贴到该组中？
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
除了偶尔的语法外没有其他错误，但实际上不知道如何构造用于检查每个组的循环。我将继续研究和测试发现的问题，并在需要时进行更新。
答案 0 :(得分：1)
看看这是否有帮助...我已在代码中添加了注释，但请随时提出其他问题：
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
编辑：其他示例
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
答案 1 :(得分：0)
最后，我更改了主要逻辑，但这应该可行。而不是复制和粘贴，我只是使group1工作表中的范围等于行的范围。我还使用最后使用的行。
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
答案 2 :(得分：0)
另一种方式。
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