1
说明的代码：VBA - 变化省略重复允许重复
我有一些代码在打开文件需要从以下两个特定的列标题的信息，并将其打印到一个主文件。它将信息打印到我的主文件到第3栏，然后是第2栏，然后是第1栏，基于单元数在第3栏。第1,2和3栏应始终具有相同的长度（包含空格）
I目前使用一个GetValue函数，它可以找到一个特定的头文件，例如HOLDER，并从最后一个被占用的行中抓取所有的值，但不包括头部HOLDER。它省略了任何重复项。
问题是我需要在工作表中有重复项。原因是第二列和第三列的值相互对应。所以，如果一个重复的不打印到第3列，这并不意味着有在列重复2
例子：
3 4
2 4
1 7
*next file*
1 9
7 6
将成为
3 4
2 7
1 9
*next file*
1 6
7
（第2列由于省略了重复值“4”而向上移动，第1列中的1不会被省略，因为它只省略了同一列中相同打开文件内的重复项）
因此，我没有得到我需要的重复信息（使用我的示例，2和4应该不对应于2和7），并且列对齐被抛弃。
任何想法，我可以去解决这个问题吗？
采用的GetValues功能：
'(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 TOOLS 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
'if no HOLDER header is found on the sheet
StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDERS PRESENT!"
End If
的GetValues功能：
'(8)
'get all unique column values starting at cell c
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 = "none"
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 TOOLS 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
'if no HOLDER header is found on the sheet
StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDERS 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 all unique column values starting at cell c
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 = "none"
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
'Dictionary'是我的唯一* *值保持...'如果不dict.exists（theValue）然后 dict.Add theValue，theValue'但你要重复？ – bonCodigo
是的，当时我是VBA的全新品牌，所以我没有意识到当我说我需要一个独特的范围时，忽略重复将成为其中的一部分。我的意思不是一致的范围，这是非常具有误导性的。我对此表示歉意。是的，我现在需要包含重复项。有小费吗？ @bonCodigo – Taylor
'1'如上所述，如果需要重复，那么'Dictionary'对象不是要使用的对象。您可以改为使用'ArrayList'。 '2'为什么你的钥匙和价值一样？例如'thevalue' – bonCodigo