Question

我想这样做：

工作簿1（

Sheet1有：

ColA:

AA
AA
AA
AB
AB
AB
AC
AC
AC
AC

现在我需要计算AA，AB，AC等等的数量，并在ColB of Work书B（Sheet1）中代表他们的数字，如下所示：

ColA:     ColB:

AA     3
AB     3
AC     4

在第二本工作簿中，Col A已经过精心设计，因此需要过滤或添加或更改Col A以更新Col（B）。

在这里用户的帮助下修改了代码到目前为止：但是我需要你的输入谢谢！

代码：

Sub foo()
Dim x As Workbook
Dim y As Workbook

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

    'Navigate to the first WOrkBook
    Windows("Book1").Activate

    'Find all the Rown in Range A that you need to copy
    Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Rows.Count).End(xlUp).Rows.Select
    Selection.Copy

    'Navigate to the Other WOrkBook
    Windows("Book2").Activate
    Sheets("Sheet2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    'This will remove the Duplicates
    ActiveSheet.Range("$A$1:$A$" & ActiveSheet.Rows.Count).End(xlUp).Rows.RemoveDuplicates Columns:=1, Header:=xlNo
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF([Book12]Sheet1!C1,RC[-1])"
    Range("B1").Select
    Selection.AutoFill Destination:=Range("B1:B" & Rows.Count).End(xlUp).Rows

    Range("B1:B" & Rows.Count).End(xlUp).Rows.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


'Close x:
x.Close
End Sub

Answer 1

以下是我使用RemoveDuplicates功能的方法：

'# 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

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

Answer 2

根据我自己的经验，我会避免使用.copy功能。相反，我建议使用数组来识别唯一的项目列表。

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

'Navigate to the first WOrkBook
Windows("Book1").Activate
Sheets("Sheet1").Select

'identify end of source tab
source_ROW = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Do While Range("A" & source_ROW) = ""
    source_ROW = source_ROW - 1
Loop
source_ROW_end = source_ROW
source_ROW_start = 3

'initialize unique value array
Dim unique_ARRAY() As String
ReDim unique_ARRAY(1 To 1)
unique_ARRAY(1) = Range("A" & source_ROW_start)

'identify unique list
For source_ROW = source_ROW_start To source_ROW_end
    'initialize
    source_record = Range("A" & source_ROW)
    new_value = "dunno_yet"

    For i = 1 To UBound(unique_ARRAY, 1)
        If source_record = unique_ARRAY(i) Then
            'value already exists in the array
            new_value = "no"

            'no need to continue searching
            Exit For
        End If
    Next i

    If new_value = "no" Then
        'the source_record matched values already found in the array
        'does nothing
    Else
        'a new source_record was found
        'new_value = "yes"

        'redimensionalize the array while preserving pre-existing values
        ReDim Preserve unique_ARRAY(1 To UBound(unique_ARRAY) + 1)

        'read the new value into the new upper bound of the array
        unique_ARRAY(UBound(unique_ARRAY, 1)) = source_record
    End If
Next source_ROW

'Navigate to the Other WOrkBook
Windows("Book2").Activate
Sheets("Sheet2").Select

'cycle through each item in the array
for i = 1 to UBound(unique_ARRAY)
    'write values to book2
    Range("A" & i) = unique_ARRAY(i)
    Range("B" & i) = "=COUNTIF([Book1]Sheet1!C1,RC[-1])"
    'convert formulas to values
    Range("B" & i).Copy
    Range("B" & i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
next i

'Close x:
x.Close
End Sub

您也可以考虑调整数组以计算值出现的次数。然后你可以在最后删除.PasteSpecial。

将工作簿1（＆＃34; A＆＃34;）中存在的值的数量复制到B列的工作簿2：VBA

2 个答案: