VBA – 允许重复
我有一个函数（在通过多个文件循环的程序中）获取列中的值并将其打印到一个文件中。 这是省略重复的， 我需要它包括重复的值 。 我是VBA新手，所以我甚至不能确定它不允许这些重复的地方。
如果你有一个解决scheme允许重复，甚至可以帮助我找出不允许重复的地方，这将是非常有帮助的。 请帮忙。
这里是获取我认为也不允许重复值的值的函数：
'(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
在不重写所有内容的情况下，只需在字典中添加递增键，并确保使用从函数返回的数据字典值，而不是键。
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
用下面的代码replaceGetvalues函数。 它会工作。
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