VBA - 允许重复项

我有一个函数（在一个程序中，通过多个文件循环）抓取列中的值并将其打印到一个文件中。这是省略重复和我需要它包括重复值。我是VBA的新手，所以我甚至无法确定它不允许这些副本的位置。VBA - 允许重复项

如果您有一个允许重复的解决方案，或者甚至可以帮助我确定它不允许重复的位置，那将非常有帮助。请帮忙。

这里是获取，我相信也不会允许重复值的值的函数：

'(8) 
'get column values 
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary 

    Dim dict As Scripting.Dictionary 
    Dim dataRange As Range 
    Dim cell As Range 
    Dim theValue As String 
    Dim splitValues As Variant 

    Set dict = New Scripting.Dictionary 
    Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells 
    ' If there are no values in this column then return an empty dictionary 
    ' If there are no values in this column, the dataRange will start at the row 
    ' *above* ch and end at ch 
    If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then 
     GoTo Exit_Function 
    End If 

    For Each cell In dataRange.Cells 
     theValue = Trim(cell.Value) 
     If Len(theValue) = 0 Then 
      theValue = " " 
     End If 
      'exclude any info after ";" 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ";") 
       theValue = splitValues(0) 
      End If 
      'exclude any info after "," 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ",") 
       theValue = splitValues(0) 
      End If 

      If Not dict.exists(theValue) Then 
      dict.Add theValue, theValue 
     End If 
    Next cell 
Exit_Function: 
    Set GetValues = dict 
End Function

全码：

Option Explicit 

Sub LoopThroughDirectory() 

    Const ROW_HEADER As Long = 10 

    Dim objFSO As Object 
    Dim objFolder As Object 
    Dim objFile As Object 
    Dim dict As Object 
    Dim MyFolder As String 
    Dim f As String 
    Dim StartSht As Worksheet, ws As Worksheet 
    Dim WB As Workbook 
    Dim i As Integer 
    Dim LastRow As Integer, erow As Integer 
    Dim Height As Integer 
    Dim FinalRow As Long 
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range 
    Dim TDS As Range 
    Dim hc12 As Range, n As Range 

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1") 

    'turn screen updating off - makes program faster 
    Application.ScreenUpdating = False 

    'location of the folder in which the desired TDS files are 
    MyFolder = "C:\Users\trembos\Documents\TDS\progress\" 

    'find the headers on the sheet 
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER") 
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL") 
    Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):") 

    'create an instance of the FileSystemObject 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    'get the folder object 
    Set objFolder = objFSO.GetFolder(MyFolder) 
    i = 2 

    'loop through directory file and print names 
'(1) 
    For Each objFile In objFolder.Files 
     If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then 
'(2) 
      'Open folder and file name, do not update links 
      Set WB = Workbooks.Open(FileName:=MyFolder & objFile.Name, UpdateLinks:=0) 
      Set ws = WB.ActiveSheet 

      With WB 
       For Each ws In .Worksheets 
'(3) 
       'find CUTTING TOOL on the source sheet 
       If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc.Offset(1, 0), "SplitMe") 
        If dict.count > 0 Then 
        'add the values to the master list, column 3 
         Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the CUTTING TOOL header 
         StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = " " 
        End If 
       'Else find CUTTING WHEEL on the source sheet 
       ElseIf Not ws.Range("A1:M15").Find(What:="CUTTING WHEEL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc = ws.Range("A1:M15").Find(What:="CUTTING WHEEL", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc.Offset(1, 0), "SplitMe") 
        If dict.count > 0 Then 
        'add the values to the master list, column 3 
         Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
        'if no items are under the CUTTING TOOL header 
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = " " 
       End If 
       Else 
        'if no CUTTING TOOL header is found on the sheet 
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO CUTTING TOOL PRESENT" 
       End If 
'(4) 
       'find HOLDER on the source sheet 
       If Not ws.Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc3 = ws.Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc3.Offset(1, 0)) 
        If dict.count > 0 Then 
         'add the values to the master list, column 2 
         Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the HOLDER header 
         StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = " " 
        End If 
       'Else find WHEEL ARBOR on the source sheet 
       ElseIf Not ws.Range("A1:M15").Find(What:="WHEEL ARBOR", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc3 = ws.Range("A1:M15").Find(What:="WHEEL ARBOR", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc3.Offset(1, 0)) 
        If dict.count > 0 Then 
         'add the values to the master list, column 2 
         Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the HOLDER header 
         StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = " " 
        End If 
       'Else find HOLDER/ARBOR # on the source sheet 
       ElseIf Not ws.Range("A1:M15").Find(What:="HOLDER/ARBOR #", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
       Set hc3 = ws.Range("A1:M15").Find(What:="HOLDER/ARBOR #", LookAt:=xlWhole, LookIn:=xlValues) 
        Set dict = GetValues(hc3.Offset(1, 0)) 
        If dict.count > 0 Then 
         'add the values to the master list, column 2 
         Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) 
         d.Resize(dict.count, 1).Value = Application.Transpose(dict.items) 
        Else 
         'if no items are under the HOLDER header 
         StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = " " 
        End If 

       Else 
        'if no HOLDER header is found on the sheet 
        StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDER PRESENT" 
       End If 
'(5) 
       'print the file name to Column 4 
       StartSht.Cells(i, 4) = objFile.Name 

       With ws 
       'Print TDS name by searching for header 
        If Not ws.Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then 
         Set TDS = ws.Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1) 
         StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS 
        Else 
         'print the file name wihtout the extension 
         StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = GetFilenameWithoutExtension(objFile.Name) 
        End If 
        i = GetLastRowInSheet(StartSht) + 1 
       End With 

       Next ws 
'(6) 
       'close, do not save any changes to the opened files 
       .Close SaveChanges:=False 
      End With 
     End If 
'(7) 
    'move to next file 
    Next objFile 
    'turn screen updating back on 
    Application.ScreenUpdating = True 
    ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile 
End Sub 
'(8) 
'get column values 
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary 

    Dim dict As Scripting.Dictionary 
    Dim dataRange As Range 
    Dim cell As Range 
    Dim theValue As String 
    Dim splitValues As Variant 

    Set dict = New Scripting.Dictionary 
    Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells 
    ' If there are no values in this column then return an empty dictionary 
    ' If there are no values in this column, the dataRange will start at the row 
    ' *above* ch and end at ch 
    If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then 
     GoTo Exit_Function 
    End If 

    For Each cell In dataRange.Cells 
     theValue = Trim(cell.Value) 
     If Len(theValue) = 0 Then 
      theValue = " " 
     End If 
      'exclude any info after ";" 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ";") 
       theValue = splitValues(0) 
      End If 
      'exclude any info after "," 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ",") 
       theValue = splitValues(0) 
      End If 

      If Not dict.exists(theValue) Then 
      dict.Add theValue, theValue 
     End If 
    Next cell 
Exit_Function: 
    Set GetValues = dict 
End Function 
'(9) 
'find a header on a row: returns Nothing if not found 
Function HeaderCell(rng As Range, sHeader As String) As Range 
    Dim rv As Range, c As Range 
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells 
     'copy cell value if it contains some string "holder" or "cutting tool" 
     If Trim(c.Value) = sHeader Then 
     'If InStr(c.Value, sHeader) <> 0 Then 
      Set rv = c 
      Exit For 
     End If 
    Next c 
    Set HeaderCell = rv 
End Function 
'(10) 
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String) 
    With theWorksheet 
     GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row 
    End With 
End Function 
'(11) 
Function GetLastRowInSheet(theWorksheet As Worksheet) 
Dim ret 
    With theWorksheet 
     If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
      ret = .Cells.Find(What:="*", _ 
          After:=.Range("A1"), _ 
          LookAt:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
     Else 
      ret = 1 
     End If 
    End With 
    GetLastRowInSheet = ret 
End Function 
'(12) 
'get the file name without the extension 
Function GetFilenameWithoutExtension(ByVal FileName) 
    Dim Result, i 
    Result = FileName 
    i = InStrRev(FileName, ".") 
    If (i > 0) Then 
    Result = Mid(FileName, 1, i - 1) 
    End If 
    GetFilenameWithoutExtension = Result 
End Function

来源

2015-06-18 Taylor

整个代码是专门写入，不允许重复。这就是为什么使用字典。您需要重写一下以允许重复。 –

字典对象不能有重复键 – Roland

然后用数组替换字典 – EngJon

不重写所有内容，只需在字典中放一个递增键，并确保使用从函数返回的数据字典值，而不是密钥。

Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary 

Dim dict As Scripting.Dictionary 
Dim dataRange As Range 
Dim cell As Range 
Dim theValue As String 
Dim splitValues As Variant 
Dim counter as Long 
Set dict = New Scripting.Dictionary 
Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells 
' If there are no values in this column then return an empty dictionary 
' If there are no values in this column, the dataRange will start at the row 
' *above* ch and end at ch 
If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then 
    GoTo Exit_Function 
End If 

For Each cell In dataRange.Cells 
    counter = counter + 1 
    theValue = Trim(cell.Value) 
    If Len(theValue) = 0 Then 
     theValue = " " 
    End If 
     'exclude any info after ";" 
     If Not IsMissing(vSplit) Then 
      splitValues = Split(theValue, ";") 
      theValue = splitValues(0) 
     End If 
     'exclude any info after "," 
     If Not IsMissing(vSplit) Then 
      splitValues = Split(theValue, ",") 
      theValue = splitValues(0) 
     End If 

     If Not dict.exists(theValue) Then 
     dict.Add counter, theValue 
    End If 
Next cell Exit_Function: 
Set GetValues = dict 

End Function

来源

2015-06-18 13:17:25 GELR

这工作很好。你能解释为什么数据字典修正它而不是密钥？非常感谢！ @GELR – Taylor

所有的答案都遵循同样的想法：既然你不使用密钥，你可以将它设置为一个计数器或任何其他的唯一值 – Roland

@Roland啊我看到这是如何搞砸了。谢谢！如果有机会，你想帮我一个小问题http://stackoverflow.com/questions/30918113/vba-transfer-empty-cell-to-sheet – Taylor

与下面的代码替换的GetValues功能。它会工作。

Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary 

    Dim dict As Scripting.Dictionary 
    Dim dataRange As Range 
    Dim cell As Range 
    Dim theValue As String 
    Dim splitValues As Variant 
    Dim icounter As Long 

    icounter = 1 
    Set dict = New Scripting.Dictionary 
    Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells 
    ' If there are no values in this column then return an empty dictionary 
    ' If there are no values in this column, the dataRange will start at the row 
    ' *above* ch and end at ch 
    If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.Count = 2) And (Trim(ch.Value) = "") Then 
     GoTo Exit_Function 
    End If 

    For Each cell In dataRange.Cells 
     theValue = Trim(cell.Value) 
     If Len(theValue) = 0 Then 
      theValue = " " 
     End If 
      'exclude any info after ";" 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ";") 
       theValue = splitValues(0) 
      End If 
      'exclude any info after "," 
      If Not IsMissing(vSplit) Then 
       splitValues = Split(theValue, ",") 
       theValue = splitValues(0) 
      End If 


      dict.Add theValue, icounter 

      icounter = icounter + 1 

    Next cell 
Exit_Function: 
    Set GetValues = dict 
End Function

来源

2015-06-18 13:14:37

之前使用过。好吧，我把它放在我的代码中，我得到了一个运行时错误_这个键已经和'dict.Add theValue，icounter'这行中的这个collection_的一个元素相关联了。当我得到这个之前，是什么修正了在那个说'如果不存在（theValue）Then'的那个之前放了一行。这样做还是你有不同的建议？ @Prabukrishna – Taylor

这也给我回数字不值，所以我不知道哪里出了问题 – Taylor

在那条线上切换'theValue'和'icounter' – EngJon

VBA - 允许重复项

回答

相关问题