将工作簿1（“A”）中存在的值的数量复制到Column B的工作簿2:VBA

我想这样做：

ColA:     ColB:

AA     3
AB     3
AC     4

工作手册1(

第1张有：

ColA:

AA
AA
AA
AB
AB
AB
AC
AC
AC
AC

现在，我需要计算有多少是AA、AB、AC等，并在工作手册B（表1）的列中表示它们的数字，如下所示：

ColA:     ColB:

AA     3
AB     3
AC     4

在这第二本工作手册中，列A已经添加，所以需要过滤、添加或更改列A以更新列（B）

在用户的帮助下，这里的代码修改至今：但我需要您的输入谢谢

代码：

---

根据我自己的经验，我会避免使用

.copy

功能。相反，我建议使用数组来标识唯一的项目列表

”#首先打开两个工作簿：
设置x=Workbooks.Open（“C:\Users\ax1jk3\Desktop\Workbooks\Book2”）
设置y=Workbooks.Open（“C:\Users\ax1jk3\Desktop\Workbooks\Book1”）
'导航到第一个工作簿
Windows（“Book1”）。激活
图纸（“图纸1”）。选择
'标识源的结尾选项卡
source_ROW=ActiveSheet.UsedRange.ROW-1+ActiveSheet.UsedRange.Rows.Count
Do While范围（“A”行和源行）=“”
source_行=source_行-1
环
source\u ROW\u end=source\u ROW
源\行\开始=3
'初始化唯一值数组
Dim unique_ARRAY（）作为字符串
ReDim唯一_阵列（1对1）
唯一数组（1）=范围（“A”和源行开始）
'识别唯一列表
对于源行=源行开始到源行结束
“初始化
源记录=范围（“A”和源记录行）
新建值=“还不知道”
对于i=1到uBond（唯一的_数组，1）
如果源记录=唯一数组（i），则
'值已存在于数组中
新值=“否”
“无需继续搜索
退出
如果结束
接下来我
如果new_value=“否”，则
'源记录匹配数组中已找到的值
”“什么也不做
其他的
'找到了新的源\u记录
'新值=“是”
'在保留预先存在的值的同时重新对数组进行尺寸化
ReDim保留唯一_数组（1到UBound（唯一_数组）+1）
'将新值读入数组的新上限
唯一_数组（UBound（唯一_数组，1））=源_记录
如果结束
下一个源行
'导航到其他工作簿
Windows（“Book2”）。激活
图纸（“图纸2”）。选择
'循环遍历数组中的每个项
对于i=1到UBound（唯一_数组）
'将值写入book2
范围（“A”&i）=唯一数组（i）
范围（“B”&i）==COUNTIF（[Book1]Sheet1！C1，RC[-1]）”
'将公式转换为值
范围（“B”和i）。复制
范围（“B”&i）.粘贴特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlanks:=False，转置：=False
接下来我
'关闭x:
x、 接近
端接头

---

你也可以考虑调整数组来计算一个值出现的次数。然后，你可以去掉<代码> .PaseStimule结尾。

< P>这里，我将如何使用ReaveDebug函数：< /P>

'# Opening both workbooks first:
Set x = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book2.xlsx")
Set y = Workbooks.Open("C:\Users\ax1jk3\Desktop\Workbooks\Book1.xlsx")

'Navigate to the first WorkBook
x.Sheets(1).Activate

'Copy-Paste column A to y.sheets(1)
lastRow_x = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:A" & lastRow_x).Copy

'Paste and remove duplicates
y.Sheets(1).Activate
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Range("A:A").RemoveDuplicates  Columns:=1, Header:=xlNo 'if your column has a header, use xlYes

'Count number of occurences of each row from y in x
lastRow_y = Range("A" & Rows.Count).End(xlUp).Row
For each loopCell in Range("A1:A" & lastRow_y) 'A2 if you have a header
   loopCell.Offset(0, 1) = Sheets(1).Evaluate("=COUNTIF([Book2.xlsx]Sheet1!A1:A" & lastRow_x & "," & loopCell.Address & ")")
next loopCell

'Close x:
x.Close SaveChanges:=xlNo

End Sub

---

我还没有测试过它，但它应该非常快！

你不能用透视表来做这件事吗？是的，我可以用透视表来做，但我需要一个宏来运行，不使用透视表。谢谢你，这也是开始使用vba时的一件重要事情（这是我学到的第一件事），您应该始终避免使用

。选择
嗨，亚瑟，谢谢您的建议：我有一个问题，例如，如果我只想在“Y”的列（A6:A24）中粘贴，我将您的修改为：Y.Sheets（1）。激活范围（“A6:A24”）。粘贴特殊的XLPasteValues和NumberFormats范围（“A6:A24”）.RemovedUpplicates列：=1，标题：=xlNo，但N=b1 19到111发生此操作是删除“A”中存在的所有其他值并放置。但实际上，我需要从和仅从（A6:A24）中粘贴和删除重复项A可能包含我不想更改或删除的其他值。谢谢。如果您愿意，我想您只能在
范围（“A6:A24”）
上使用
RemoveDuplicates
。我知道您在文件Y的A列中已经有数据，那么我建议您在另一个临时列上使用
RemoveDuplicates
函数（例如，可能在工作表（2）中），以确保不会覆盖现有数据。。。