VBA - 允许重复

时间：2015-06-18 12:45:43

标签： excel vba excel-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

2 个答案:

答案 0 :(得分：3)

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

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

答案 1 :(得分：1)

使用以下代码替换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
相关问题
最新问题