您好我有一些VBA代码，可以根据要查看的特定列在Excel中搜索重复的行。我试图将其转换为VB但是我得到错误： COMException未处理 来自HRESULT的异常：0x800A0005（CTL_E_ILLEGALFUNCTIONCALL）
我得到了这个＆＃34;如果includedColumns.Exists（j）那么＆＃34;。 代码是：
Public Sub btnRun_Click(sender As System.Object, e As System.EventArgs) Handles btnRun.Click
Dim xlApp As Excel.Application
Dim xlWorkBook1 As Excel.Workbook ' Interactions
Dim xlWorkBooks As Excel.Workbooks
Dim MainSheet1 As Excel.Worksheet
xlApp = New Excel.Application
xlWorkBooks = xlApp.Workbooks
xlWorkBook1 = xlWorkBooks.Open(File1_name)
MainSheet1 = xlWorkBook1.Sheets(1)
Dim InteractionRows As Long = MainSheet1.UsedRange.Rows.Count ' Total number of rows in the Interaction worksheet
Dim totalURCols As Long = MainSheet1.UsedRange.Columns.Count ' get last used col on sheet for duplicate issue calc
' For Duplicate Issue ----------------------------------------------------------------------------------------
Const LAST_COL As Long = 40 ' Update last column + 1 (ie. will update the 41th column, AO)
Const FIRST_ROW As Long = 2 ' The row the data starts, ie not including the header
Const FIRST_COL As Long = 1 ' The row the data starts
Const dupe As String = "1" ' This will be the flag
Const CASE_SENSITIVE As Byte = 1 ' Matches UPPER & lower
Dim searchRng As Range ' Search Range
Dim memArr As Object
Dim i As Long
Dim j As Long
Dim unique As String
Dim includedColumns As New Scripting.Dictionary ' Define storage for the columns you want to be used as duplicate issue search criteria.Create a Dictionary (a storage method) from the Microsoft Scripting Runtime library
Dim valDict As New Scripting.Dictionary ' For Upper and Lower case comparison
With includedColumns ' Add the following columns to the Dictionary
.Add(4, "") ' Creation date
.Add(8, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 8 (H) CALL_TYPE as duplicate issue criteria
.Add(10, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 10 (J) IT_Service as duplicate issue criteria
.Add(11, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 11 (K) Business_Service as duplicate issue criteria
.Add(21, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 21 (U) Affected_Staff_Id as duplicate issue criteria
End With
unique = vbNullString
If CASE_SENSITIVE = 1 Then
valDict.CompareMode = vbBinaryCompare
Else
valDict.CompareMode = vbTextCompare
End If
' Flag Creation
searchRng = MainSheet1.Range(MainSheet1.Cells(FIRST_ROW, FIRST_COL), _
MainSheet1.Cells(InteractionRows, LAST_COL))
If LAST_COL < totalURCols Then
MainSheet1.Range(MainSheet1.Cells(FIRST_ROW, LAST_COL + 1), _
MainSheet1.Cells(FIRST_ROW, totalURCols)).EntireColumn.Delete() 'delete any extra columns
End If
memArr = searchRng.Resize(InteractionRows, LAST_COL + 1) 'entire range with data to mem
For i = 1 To InteractionRows 'each row, without the header
For j = 1 To LAST_COL 'each col
If includedColumns.Exists(j) Then
unique = unique & searchRng(i, j) 'concatenate values on same row
End If
Next
If valDict.Exists(unique) Then 'check if entire row exists
memArr(i, LAST_COL + 1) = dupe 'if it does, flag it in last col
Else
valDict.Add(Key:=unique, Item:=i) 'else add it to the dictionary
memArr(i, LAST_COL + 1) = "0"
End If
unique = vbNullString
Next
End Sub
End Class
非常感谢任何协助。
答案 0 :(得分：0)
使用Generic Dictionary
的类似方法Public Sub btnRun_Click(sender As System.Object, e As System.EventArgs) Handles btnRun.Click
Dim xlApp As Excel.Application
Dim xlWorkBook1 As Excel.Workbook ' Interactions
Dim xlWorkBooks As Excel.Workbooks
Dim MainSheet1 As Excel.Worksheet
xlApp = New Excel.Application
xlWorkBooks = xlApp.Workbooks
xlWorkBook1 = xlWorkBooks.Open(File1_name)
MainSheet1 = xlWorkBook1.Sheets(1)
Dim InteractionRows As Long = MainSheet1.UsedRange.Rows.Count ' Total number of rows in the Interaction worksheet
Dim totalURCols As Long = MainSheet1.UsedRange.Columns.Count ' get last used col on sheet for duplicate issue calc
' For Duplicate Issue ----------------------------------------------------------------------------------------
Const LAST_COL As Long = 40 ' Update last column + 1 (ie. will update the 41th column, AO)
Const FIRST_ROW As Long = 2 ' The row the data starts, ie not including the header
Const FIRST_COL As Long = 1 ' The row the data starts
Const dupe As String = "1" ' This will be the flag
Const CASE_SENSITIVE As Byte = 1 ' Matches UPPER & lower
Dim searchRng As Range ' Search Range
Dim memArr As Object
Dim i As Long
Dim j As Long
Dim unique As String
Dim includedColumns As New Dictionary(Of Long, Object) ' Define storage for the columns you want to be used as duplicate issue search criteria.Create a Dictionary (a storage method) from the Microsoft Scripting Runtime library
Dim valDict As New Dictionary(Of String, Long) ' For Upper and Lower case comparison
With includedColumns ' Add the following columns to the Dictionary
.Add(4, "") ' Creation date
.Add(8, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 8 (H) CALL_TYPE as duplicate issue criteria
.Add(10, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 10 (J) IT_Service as duplicate issue criteria
.Add(11, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 11 (K) Business_Service as duplicate issue criteria
.Add(21, "") ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 21 (U) Affected_Staff_Id as duplicate issue criteria
End With
unique = vbNullString
'If CASE_SENSITIVE = 1 Then
' valDict.CompareMode = vbBinaryCompare
'Else
' valDict.CompareMode = vbTextCompare
'End If
' Flag Creation
searchRng = MainSheet1.Range(MainSheet1.Cells(FIRST_ROW, FIRST_COL), _
MainSheet1.Cells(InteractionRows, LAST_COL))
If LAST_COL < totalURCols Then
MainSheet1.Range(MainSheet1.Cells(FIRST_ROW, LAST_COL + 1), _
MainSheet1.Cells(FIRST_ROW, totalURCols)).EntireColumn.Delete() 'delete any extra columns
End If
memArr = searchRng.Resize(InteractionRows, LAST_COL + 1) 'entire range with data to mem
For i = 1 To InteractionRows 'each row, without the header
For j = 1 To LAST_COL 'each col
If includedColumns.ContainsKey(j) Then
unique = unique & searchRng(i, j) 'concatenate values on same row
End If
Next
If valDict.ContainsKey(unique) Then 'check if entire row exists
memArr(i, LAST_COL + 1) = dupe 'if it does, flag it in last col
Else
valDict.Add(unique, i) 'else add it to the dictionary
memArr(i, LAST_COL + 1) = "0"
End If
unique = vbNullString
Next
End Sub