Excel VBA代码错误类型不匹配使用工作表函数查找重复项

Question

我得到一个

类型不匹配错误“13”

使用下面的代码。任何人都可以帮助我解决我的 VBA 语法和变量使用方面的问题。

If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then

我尝试了 matchFoundIndex 代码方法，但没有成功...可能是由于 VBA 语法不正确。

CountIf 行的目的是在 A 列中查找重复项。其余代码循环遍历文件和工作表，复制文件名、工作表名称和单元格 C1 以供进一步分析。我是编码新手，我确信可能存在我未使用的 Dimmed 变量、其他格式以及我尚未发现的错误。任何帮助将不胜感激。

Sub CopyFileAndStudyName()

Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean

sPath = "C:\Users\mypath\"

' which row to begin writing to in the activesheet
lngRow = 2

SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False

If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub

Do While SName <> ""
    lngwsh = 1
    ' Will cycle through all .xlsx files in sPath
    Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
    ' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
        For lngwsh = 1 To 3
            Set sh = ActiveSheet
            sh.Cells(lngRow, "A") = xlWB.Name
            sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
            sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name

            Dim Target As Range
            Dim r As Range
            Dim lastRow As Long
            Dim ws As Worksheet

            Set ws = xlWB.Worksheets(lngwsh)

            With ws
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                Set Target = ws.Range("A1:A" & lastRow)
            End With
                For Each r In Target
                        If r.Value <> "" Then
                            If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
                                FindDuplicates = True
                                Exit For
                            Else
                                FindDuplicates = False
                            End If
                        End If
                Next r

            Debug.Print FindDuplicates

            IsDup = FindDuplicates

            sh.Cells(lngRow, "D") = IsDup
            FindDuplicates = False

               End If
 lngRow = lngRow + 1
 Next lngwsh

 xlWB.Close False
 xlApp.Quit
 SName = Dir()
 Loop
 MsgBox "Report Ready!"
 End Sub

Answer 1

如果要检查范围内的重复项，可以使用Dictionary 对象。

Dim Dict As Object

Set Dict = CreateObject("Scripting.Dictionary")

For Each r In Target
    If Trim(r.Value) <> "" Then
        If Not Dict.exists(r.Value) Then  ' not found in dictionary >> add Key
            Dict.Add r.Value, r.Value
            FindDuplicates = False               
        Else ' found in Dictionary >> Exit
            FindDuplicates = True
            Exit For
         nd If
    End If
Next r

Answer 2

Sub CopyFileAndStudyName()

Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean

sPath = "C:\Users\mypath\"

' which row to begin writing to in the activesheet
lngRow = 2

SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False

If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub

Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D

     For lngwsh = 1 To 3
        Set sh = ActiveSheet
        sh.Cells(lngRow, "A") = xlWB.Name
        sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
        sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name

        Dim Target As Range
        Dim r As Range
        Dim lastRow As Long
        Dim ws As Worksheet

        Set ws = xlWB.Worksheets(lngwsh)

        With ws
            lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set Target = ws.Range("A1:A" & lastRow)
        End With
            For Each r In Target
                    If r.Value <> "" Then
                        If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
                            FindDuplicates = True
                            Exit For
                        Else
                            FindDuplicates = False
                        End If


                    End If
            Next r

        Debug.Print FindDuplicates

        IsDup = FindDuplicates

        sh.Cells(lngRow, "D") = IsDup
        FindDuplicates = False


lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub