如果满足条件，使用 VBA 将唯一行复制到另一个电子表格
Use VBA to copy unique rows to another spreadsheet if condition is met
我是 VBA 的新手，如有任何帮助，我们将不胜感激！
我的办公室正在协调美国各地的职位申请。当人们申请时，他们会选择他们愿意在哪两个州工作。所有申请信息都手动输入到工作表 A 中，该工作表有很多列，但有 5 个重要的列：唯一 ID、名字、姓氏、首选州1 , 首选状态 2。此工作表每天更新。
我有 50 张工作表（美国每个州一张）。我编写了 VBA 代码，在创建状态工作表时将电子表格 A 中的每一行复制到 50 个状态工作表中。
我需要将每天添加到电子表格 A 的新信息复制到相应的状态电子表格中。所有选择州的申请人都需要进入州工作表（州优先顺序无关紧要）。
例如，今天，电子表格 A 可能是：
ID
First Name
Last Name
State1
State2
111
Bob
Belcher
New Jersey
Alaska
222
Rose
Nylund
Minnesota
Florida
333
Beef
Tobin
Alaska
California
因此阿拉斯加电子表格将具有：
ID
First Name
Last Name
111
Bob
Belcher
333
Beef
Tobin
明天，工作表 A 可以添加新人（ID 444 和 555），我只想将选择阿拉斯加的新人添加到阿拉斯加工作表（ID 555 Colin Robinson）。
ID
First Name
Last Name
State1
State2
111
Bob
Belcher
New Jersey
Alaska
222
Rose
Nylund
Minnesota
Florida
333
Beef
Tobin
Alaska
California
444
Charlie
Bucket
New York
Florida
555
Colin
Robinson
New York
Alaska
我是根据 A 列中的唯一 ID 使用此代码，但它没有考虑不同的状态。
Sub Copy ()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheet4
Set sh2 = Sheet1
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("B2:B" & lr)
For Each c In rng
If WorksheetFunction.CountIf(sh2.Range("B:B"), c.Value) = 0 Then
sh2.Range("B" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)(2).Resize(1, 5) = c.Resize(1, 5).Value
End If
Next
End Sub
如果我想要的唯一宏是在电子表格 A 中，而您只想使用 copy-paste 来传输数据而不是 sql。
，那么我会这样做
注意：以下带*的项目，您可以录制一个宏来为您生成代码并将其粘贴到您的函数中以快速拼凑代码。
- 首先设置ScreenUpdating=false 来消除屏幕
闪烁。
- 创建要循环的状态名称数组。
- 在循环中，对电子表格应用过滤器以将行减少到仅与当前“状态”匹配的行*
- 打开其他文件 - 请务必使用状态名称命名文件，以便您可以使用数组引用文件名。 （参见 Workbooks.Open）
- 通过在州电子表格的 A1* 处插入行进行粘贴。
- Select 全部并执行菜单选项数据-->删除重复项*
如果您的数据使 #6 成为问题，则需要更多代码来检查现有数据。
再见，
肖恩
在If之前的For循环中，添加
Set sh2 = ThisWorkbook.Worksheets(c.Offset(, 3).Value2)
这要求州列中的值与州 sheet 姓名
完全匹配
要处理第二个状态，请使用 Offset(, 4)
重复 Set 和 If 块
如果此代码太慢，请考虑切换到变体数组方法
将数据导出到多个工作表
- 为避免创建重复项，我添加了第 6 个 (
sfrCol) 标志列，该列将在传输的每一行中包含 "Yes" (sFlag)。该代码只是在寻找任何内容，因此您可以使用任何您喜欢的值。
- 代码将首先在此标志列中找到第一个可用单元格以引用未传输的数据范围。
- 然后它将循环遍历该范围内的行并相应地传输（复制）这些行，必要时创建新的工作表，否则，将这些行追加到已写入的数据之后。
Option Explicit
Sub ExportByCountry()
' Source
Const sName As String = "A" ' Worksheet Name
Const slrCol As Long = 1 ' Last Row Column
Const sfrCol As Long = 6 ' Flag Column
Const sFlag As String = "Yes"
Dim stCols As Variant: stCols = VBA.Array(1, 2, 3) ' Transfer Columns
Dim scCols As Variant: scCols = VBA.Array(4, 5) ' Country Columns
' Destination
Const dfCol As Long = 1 ' First Column
Const dfRow As Long = 1 ' First Row
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim stUpper As Long: stUpper = UBound(stCols)
Dim scUpper As Long: scUpper = UBound(scCols)
Dim dtCount As Long: dtCount = stUpper + 1
Dim dHeaders As Variant: ReDim dHeaders(0 To stUpper)
Dim srg As Range
Dim srCount As Long
Dim dt As Long
With sws.Range("A1").CurrentRegion ' (with headers)
' Write headers to an array.
For dt = 0 To stUpper
dHeaders(dt) = .Cells(dt + 1).Value
Next dt
srCount = .Rows.Count
' Reference the source data range (no headers)
Set srg = .Resize(srCount - 1).Offset(1)
End With
Dim sfCell As Range
s
' Reference the first available cell in the flag column ('sfCell').
With srg.Columns(sfrCol)
Set sfCell = .Find("*", , xlFormulas, , , xlPrevious)
If sfCell Is Nothing Then
Set sfCell = .Cells(1)
ElseIf sfCell.Row = srCount Then
MsgBox "Data already transferred.", vbExclamation
Exit Sub
Else
Set sfCell = sfCell.Offset(1)
End If
End With
' Reference the not flagged range ('srg').
Set srg = srg.Resize(srCount - sfCell.Row + 1).Offset(sfCell.Row - 2)
srCount = srg.Rows.Count
' Write the range to the source array ('sData').
Dim sData As Variant: sData = srg.Value
Dim dtData As Variant: ReDim dtData(0 To stUpper) ' Transfer Data Array
Dim dws As Worksheet
Dim drrg As Range ' Destination Row Range
Dim sr As Long ' Source Row Counter
Dim sc As Long ' Source Country Column Counter
For sr = 1 To srCount
For sc = 0 To scUpper
' Attempt to create a reference to the destination worksheet.
On Error Resume Next
Set dws = wb.Worksheets(sData(sr, scCols(sc)))
On Error GoTo 0
If dws Is Nothing Then ' worksheet doesn't exist
' Add a new worksheet, rename it and write the headers.
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = sData(sr, scCols(sc))
dws.Cells(dfRow, dfCol).Resize(, dtCount).Value = dHeaders
'Else ' worksheet exists; do nothing
End If
' Write the values from the row ('sr') of the source array
' to the transfer data array.
For dt = 0 To stUpper
dtData(dt) = sData(sr, stCols(dt))
Next dt
' Reference the first 'available' destination row range.
With dws.Columns(dfCol)
Set drrg = .Find("*", , xlFormulas, , , xlPrevious) _
.Offset(1).Resize(, dtCount)
End With
' Write the values from the transfer data array
' to the destinaton row range.
drrg.Value = dtData
Set dws = Nothing
Next sc
' Write the flag.
srg.Cells(sr, sfrCol).Value = sFlag
Next sr
sws.Select
'wb.Save
MsgBox "Data transferred.", vbInformation
End Sub
我是 VBA 的新手，如有任何帮助，我们将不胜感激！
我的办公室正在协调美国各地的职位申请。当人们申请时，他们会选择他们愿意在哪两个州工作。所有申请信息都手动输入到工作表 A 中，该工作表有很多列，但有 5 个重要的列：唯一 ID、名字、姓氏、首选州1 , 首选状态 2。此工作表每天更新。
我有 50 张工作表（美国每个州一张）。我编写了 VBA 代码，在创建状态工作表时将电子表格 A 中的每一行复制到 50 个状态工作表中。
我需要将每天添加到电子表格 A 的新信息复制到相应的状态电子表格中。所有选择州的申请人都需要进入州工作表（州优先顺序无关紧要）。
例如，今天，电子表格 A 可能是：
| ID | First Name | Last Name | State1 | State2 |
|---|---|---|---|---|
| 111 | Bob | Belcher | New Jersey | Alaska |
| 222 | Rose | Nylund | Minnesota | Florida |
| 333 | Beef | Tobin | Alaska | California |
因此阿拉斯加电子表格将具有：
| ID | First Name | Last Name |
|---|---|---|
| 111 | Bob | Belcher |
| 333 | Beef | Tobin |
明天，工作表 A 可以添加新人（ID 444 和 555），我只想将选择阿拉斯加的新人添加到阿拉斯加工作表（ID 555 Colin Robinson）。
| ID | First Name | Last Name | State1 | State2 |
|---|---|---|---|---|
| 111 | Bob | Belcher | New Jersey | Alaska |
| 222 | Rose | Nylund | Minnesota | Florida |
| 333 | Beef | Tobin | Alaska | California |
| 444 | Charlie | Bucket | New York | Florida |
| 555 | Colin | Robinson | New York | Alaska |
我是根据 A 列中的唯一 ID 使用此代码，但它没有考虑不同的状态。
Sub Copy ()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheet4
Set sh2 = Sheet1
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("B2:B" & lr)
For Each c In rng
If WorksheetFunction.CountIf(sh2.Range("B:B"), c.Value) = 0 Then
sh2.Range("B" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)(2).Resize(1, 5) = c.Resize(1, 5).Value
End If
Next
End Sub
如果我想要的唯一宏是在电子表格 A 中，而您只想使用 copy-paste 来传输数据而不是 sql。
，那么我会这样做注意：以下带*的项目，您可以录制一个宏来为您生成代码并将其粘贴到您的函数中以快速拼凑代码。
- 首先设置ScreenUpdating=false 来消除屏幕 闪烁。
- 创建要循环的状态名称数组。
- 在循环中，对电子表格应用过滤器以将行减少到仅与当前“状态”匹配的行*
- 打开其他文件 - 请务必使用状态名称命名文件，以便您可以使用数组引用文件名。 （参见 Workbooks.Open）
- 通过在州电子表格的 A1* 处插入行进行粘贴。
- Select 全部并执行菜单选项数据-->删除重复项*
如果您的数据使 #6 成为问题，则需要更多代码来检查现有数据。
再见， 肖恩
在If之前的For循环中，添加
Set sh2 = ThisWorkbook.Worksheets(c.Offset(, 3).Value2)
这要求州列中的值与州 sheet 姓名
完全匹配要处理第二个状态，请使用 Offset(, 4)
如果此代码太慢，请考虑切换到变体数组方法
将数据导出到多个工作表
- 为避免创建重复项，我添加了第 6 个 (
sfrCol) 标志列，该列将在传输的每一行中包含"Yes"(sFlag)。该代码只是在寻找任何内容，因此您可以使用任何您喜欢的值。 - 代码将首先在此标志列中找到第一个可用单元格以引用未传输的数据范围。
- 然后它将循环遍历该范围内的行并相应地传输（复制）这些行，必要时创建新的工作表，否则，将这些行追加到已写入的数据之后。
Option Explicit
Sub ExportByCountry()
' Source
Const sName As String = "A" ' Worksheet Name
Const slrCol As Long = 1 ' Last Row Column
Const sfrCol As Long = 6 ' Flag Column
Const sFlag As String = "Yes"
Dim stCols As Variant: stCols = VBA.Array(1, 2, 3) ' Transfer Columns
Dim scCols As Variant: scCols = VBA.Array(4, 5) ' Country Columns
' Destination
Const dfCol As Long = 1 ' First Column
Const dfRow As Long = 1 ' First Row
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim stUpper As Long: stUpper = UBound(stCols)
Dim scUpper As Long: scUpper = UBound(scCols)
Dim dtCount As Long: dtCount = stUpper + 1
Dim dHeaders As Variant: ReDim dHeaders(0 To stUpper)
Dim srg As Range
Dim srCount As Long
Dim dt As Long
With sws.Range("A1").CurrentRegion ' (with headers)
' Write headers to an array.
For dt = 0 To stUpper
dHeaders(dt) = .Cells(dt + 1).Value
Next dt
srCount = .Rows.Count
' Reference the source data range (no headers)
Set srg = .Resize(srCount - 1).Offset(1)
End With
Dim sfCell As Range
s
' Reference the first available cell in the flag column ('sfCell').
With srg.Columns(sfrCol)
Set sfCell = .Find("*", , xlFormulas, , , xlPrevious)
If sfCell Is Nothing Then
Set sfCell = .Cells(1)
ElseIf sfCell.Row = srCount Then
MsgBox "Data already transferred.", vbExclamation
Exit Sub
Else
Set sfCell = sfCell.Offset(1)
End If
End With
' Reference the not flagged range ('srg').
Set srg = srg.Resize(srCount - sfCell.Row + 1).Offset(sfCell.Row - 2)
srCount = srg.Rows.Count
' Write the range to the source array ('sData').
Dim sData As Variant: sData = srg.Value
Dim dtData As Variant: ReDim dtData(0 To stUpper) ' Transfer Data Array
Dim dws As Worksheet
Dim drrg As Range ' Destination Row Range
Dim sr As Long ' Source Row Counter
Dim sc As Long ' Source Country Column Counter
For sr = 1 To srCount
For sc = 0 To scUpper
' Attempt to create a reference to the destination worksheet.
On Error Resume Next
Set dws = wb.Worksheets(sData(sr, scCols(sc)))
On Error GoTo 0
If dws Is Nothing Then ' worksheet doesn't exist
' Add a new worksheet, rename it and write the headers.
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = sData(sr, scCols(sc))
dws.Cells(dfRow, dfCol).Resize(, dtCount).Value = dHeaders
'Else ' worksheet exists; do nothing
End If
' Write the values from the row ('sr') of the source array
' to the transfer data array.
For dt = 0 To stUpper
dtData(dt) = sData(sr, stCols(dt))
Next dt
' Reference the first 'available' destination row range.
With dws.Columns(dfCol)
Set drrg = .Find("*", , xlFormulas, , , xlPrevious) _
.Offset(1).Resize(, dtCount)
End With
' Write the values from the transfer data array
' to the destinaton row range.
drrg.Value = dtData
Set dws = Nothing
Next sc
' Write the flag.
srg.Cells(sr, sfrCol).Value = sFlag
Next sr
sws.Select
'wb.Save
MsgBox "Data transferred.", vbInformation
End Sub