求大神 这是哪错了 怎么改改 抄的程序不会

lipanbest

Sub ExtractSameItems()
    '定义变量
    Dim ws As Worksheet, wsNew As Worksheet
    Dim lastRow As Long, lastRowNew As Long
    Dim i As Long, j As Long
    Dim dict As Object
    Dim key As Variant
    Dim wsArr() As String, wsName As String, wsCount As Long

    '指定要提取的工作表名称
    wsArr = Array("Sheet1", "Sheet2", "Sheet3")
    wsCount = UBound(wsArr) - LBound(wsArr) + 1

    '创建新的工作表
    Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsNew.Name = "Same Items"
    lastRowNew = 1

    '创建字典对象
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare

    '遍历指定的工作表
    For j = LBound(wsArr) To UBound(wsArr)
        Set ws = ThisWorkbook.Sheets(wsArr(j))
        lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
        '遍历每行数据
        For i = 2 To lastRow
            '获取第一列数据作为关键字
            key = ws.Cells(i, 1).Value
            '将工作表名称和关键字作为字典的键
            wsName = ws.Name & "|" & key
            '如果字典中不存在该键，则添加到字典中
            If Not dict.exists(wsName) Then
                dict.Add wsName, 1
            '如果字典中已存在该键，则在新工作表中添加一行数据
            Else
                '获取关键字和工作表名称
                key = Mid(wsName, InStr(wsName, "|") + 1)
                wsName = Left(wsName, InStr(wsName, "|") - 1)
                lastRowNew = wsNew.Cells(Rows.Count, 1).End(xlUp).Row + 1
                wsNew.Cells(lastRowNew, 1).Value = key
                wsNew.Cells(lastRowNew, 2).Value = wsName
                wsNew.Cells(lastRowNew, 3).Value = ws.Name
            End If
        Next i
    Next j

    '遍历新工作表中的行，统计每个关键字出现的次数
    For i = 2 To lastRowNew
        key = wsNew.Cells(i, 1).Value
        wsName = wsNew.Cells(i, 2).Value
        dict(wsName & "|" & key) = dict(wsName & "|" & key) + 1
    Next i

    '在新工作表中删除出现次数小于指定工作表数的行
    For i = lastRowNew To 2 Step -1
        wsName = wsNew.Cells(i, 2).Value
        key = wsNew.Cells(i, 1).Value
        If dict(wsName & "|" & key) < wsCount Then
            wsNew.Rows(i).Delete
        End If
    Next i

    '格式化新工作表
    wsNew.Columns("A:C").AutoFit
    wsNew.Range("A1:C1").Font.Bold = True
    wsNew.Range("A1:C1").Interior.ColorIndex = 15
    wsNew.Range("A1").Value = "Same Items"
    wsNew.Range("A2").Value = "Key"
    wsNew.Range("B2").Value = "Worksheet"
    wsNew.Range("C2").Value = "Count"

    '释放资源
    Set dict = Nothing
    Set wsNew = Nothing
End Sub

zjzyj

Dim wsArr, wsName As String, wsCount As Long