VBA - 更改省略副本以允许重复 [英] VBA - change omit duplicates to allow for duplicates
问题描述
代码说明
我有一些代码,可以从打开文件中的两个特定列标题下获取信息,并将其打印到主文件。它将信息打印到我的主文件到第3列,然后列第2列,然后根据第3列中的单元格数列列1。列1,2和3应始终是相同的长度(包括空格)
我目前使用一个GetValue函数,它找到一个特定的头,例如HOLDER,并从最后一个占用的行直到但不包括标题HOLDER,抓取其下的所有值。它忽略了任何副本。
问题是我需要在工作表中有重复的。原因是第二和第三列值彼此对应。所以如果一个副本不打印到第3列,那并不意味着在第2列中有一个重复。
示例:
3 4
2 4
1 7
*下一个文件*
1 9
7 6
将成为
3 4
pre>
2 7
1 9
*下一个文件*
1 6
7
(由于省略了重复值4,第2列向上移动,列1中的1不会被忽略,因为它只会忽略重复这在同一列中的同一个打开的文件中)
因此,我没有获得该副本所需的信息(使用我的示例,那个2和4应该对应不是2和7),我的列对齐方式被抛弃。
有什么想法可以解决这个问题吗?
使用GetValues函数:
'(3)
'找到CUT源表上的TING TOOL
如果不是ws.Range(A1:M15)。Find(What:=CUTTING TOOL,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc = ws.Range(A1:M15)Find(What:=CUTTING TOOL,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc.Offset(1,0 ),SplitMe)
如果dict.count> 0然后
'将值添加到主列表,列3
设置d = StartSht.Cells(Rows.count,hc2.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有项目在CUTTING TOOL头下
StartSht.Cells( Rows.count,hc2.Column).End(xlUp).Offset(1,0)=
End If
'否则在源表上找到CUTTING WHEEL
ElseIf不是ws。范围(A1:M15)。Find(What:=CUTTING WHEEL,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc = ws.Range(A1:M15)。查找(什么:=CUTTING WHEEL,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc.Offset(1,0),SplitMe)
如果dict.count > 0然后
'将值添加到主列表,列3
设置d = StartSht.Cells(Rows.count,hc2.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有项目在CUTTING TOOL头下
StartSht.Cells( Rows.count,hc2.Column).End(xlUp).Offset(1,0)=
End If
Else
'如果没有在工作表上找到CUTTING TOOL标题
StartSht.Cells(Rows.count,hc2.Column).End(xlUp).Offset(1,0)=NO CUTTING TOOLS PRESENT
End If
'(4)
'在源表上找到HOLDER
如果不是ws.Range(A1:M15)。Find(What:=HOLDER,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc3 = ws.Range(A1:M15)Find(What:=HOLDER,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc3.Offset(1, 0))
如果dict.count> 0然后
'将值添加到主列表,列2
设置d = StartSht.Cells(Rows.count,hc1.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有任何项目在HOLDER头下
StartSht.Range(StartSht .Cells(i,2),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))=
End If
'否则在源表上找到WHEEL ARBOR
ElseIf不是ws.Range(A1:M15)Find(What:=WHEEL ARBOR,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc3 = ws.Range(A1: M15)Find(What:=WHEEL ARBOR,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc3.Offset(1,0))
如果dict.count > 0然后
'将值添加到主列表,列2
设置d = StartSht.Cells(Rows.count,hc1.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有任何项目在HOLDER头下
StartSht.Range(StartSht .Cells(i,2),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))=
End If
Else
'如果没有找到HOLDER头表单
StartSht.Range(StartSht.Cells(i,2),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))=NO HOLDERS PRESENT!
结束如果
GetValues函数:
'(8)
'从单元格开始获取所有唯一的列值c
函数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
设置dict = New Scripting.Dictionary
设置dataRange = ch.Parent.Range(ch,ch.Parent.Cells(Rows.count,ch.Column).End xlUp))。单元格
'如果此列中没有值,则返回一个空字典
'如果此列中没有值,则dataRange将从行
'*开始如果(dataRange.Row =(ch.Row - 1))和(dataRange.Rows.count = 2)和(Trim(ch.Value)=)然后
GoTo Exit_Function
End If
对于每个单元格在dataRange.C中ells
theValue = Trim(cell.Value)
如果Len(theValue)= 0然后
theValue =none
End If
' ;
如果不是IsMissing(vSplit)然后
splitValues = Split(theValue,;)
theValue = splitValues(0)
End If
' ,
如果不是IsMissing(vSplit)然后
splitValues = Split(theValue,,)
theValue = splitValues(0)
如果
如果不是dict.exists(theValue)然后
dict.Add theValue,thevalue
End If
下一个单元格
Exit_Function:
设置GetValues = dict
结束功能
全部代码
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 A s工作表,ws As工作表
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,hc4 As Range,d As Range
Dim TDS As Range
Dim hc12 As Range,n As Range
设置StartSht =工作簿(masterfile.xlsm)。表(Sheet1)
'关闭屏幕更新 - 使程序更快
Application.ScreenUpdating = False
'所需TDS文件的文件夹位置为
MyFolder =C:\Users\trembos\Documents\TDS\progress\
'找到页面上的标题
设置hc1 = HeaderCell(StartSht.Range(B1),HOLDER)
设置hc2 = HeaderCell(StartSht.Range(C1 ),CUTTING TOOL)
设置hc4 = HeaderCell(StartSht.Range(A1),TOOLING DATA SHEET(TDS):)
'创建一个实例e的FileSystemObject
设置objFSO = CreateObject(Scripting.FileSystemObject)
'获取文件夹对象
设置objFolder = objFSO.GetFolder(MyFolder)
i = 2
'循环通过目录文件和打印名称
'(1)
对于每个objFile在objFolder.Files
如果LCase(Right(objFile.Name,3))= xls或LCase(Left(Right(objFile.Name,4),3))=xls然后
'(2)
'打开文件夹和文件名,不要更新链接
设置WB = Workbooks.Open(FileName:= MyFolder& objFile.Name,UpdateLinks:= 0)
设置ws = WB.ActiveSheet
使用WB
对于每个ws In .Worksheets
'(3)
'在源表上找到CUTTING TOOL
如果不是ws.Range(A1:M15)。Find(What:=CUTTING TOOL,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc = ws.Range(A1:M15)Find(What:=CUTTING TOOL,LookAt:= xlWhole,LookIn:= xlValues)
Set dict = GetValues(hc.Offset 1,0),SplitMe)
如果dict.count> 0然后
'将值添加到主列表,列3
设置d = StartSht.Cells(Rows.count,hc2.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有项目在CUTTING TOOL头下
StartSht.Cells( Rows.count,hc2.Column).End(xlUp).Offset(1,0)=
End If
'否则在源表上找到CUTTING WHEEL
ElseIf不是ws。范围(A1:M15)。Find(What:=CUTTING WHEEL,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc = ws.Range(A1:M15)。查找(什么:=CUTTING WHEEL,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc.Offset(1,0),SplitMe)
如果dict.count > 0然后
'将值添加到主列表,列3
设置d = StartSht.Cells(Rows.count,hc2.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有项目在CUTTING TOOL头下
StartSht.Cells( Rows.count,hc2.Column).End(xlUp).Offset(1,0)=
End If
Else
'如果没有在工作表上找到CUTTING TOOL标题
StartSht.Cells(Rows.count,hc2.Column).End(xlUp).Offset(1,0)=NO CUTTING TOOLS PRESENT
End If
'(4)
'在源表上找到HOLDER
如果不是ws.Range(A1:M15)。Find(What:=HOLDER,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc3 = ws.Range(A1: M15)Find(What:=HOLDER,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc3.Offset(1,0))
如果dict.count> ; 0然后
'将值添加到主列表,列2
设置d = StartSht.Cells(Rows.count,hc1.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有任何项目在HOLDER头下
StartSht.Range(StartSht .Cells(i,2),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))=
End If
'否则在源表上找到WHEEL ARBOR
ElseIf不是ws.Range(A1:M15)Find(What:=WHEEL ARBOR,LookAt:= xlWhole,LookIn:= xlValues)Is Nothing Then
设置hc3 = ws.Range(A1: M15)Find(What:=WHEEL ARBOR,LookAt:= xlWhole,LookIn:= xlValues)
设置dict = GetValues(hc3.Offset(1,0))
如果dict.count > 0然后
'将值添加到主列表,列2
设置d = StartSht.Cells(Rows.count,hc1.Column).End(xlUp).Offset(1,0)
d.Resize(dict.count,1).Value = Application.Transpose(dict.items)
Else
'如果没有任何项目在HOLDER头下
StartSht.Range(StartSht .Cells(i,2),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))=
End If
Else
'如果没有找到HOLDER头表单
StartSht.Range(StartSht.Cells(i,2),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))=NO HOLDERS PRESENT!
End If
'(5)
'将文件名打印到列4
StartSht.Cells(i,4)= objFile.Name
使用ws
'通过搜索标题打印TDS名称
如果不是ws.Range(A1:K1)。Find(What:=TOOLING DATA SHEET(TDS):,LookAt:= xlWhole ,LookIn:= xlValues)Is Nothing Then
设置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
'打印文件名wihtout扩展名
StartSht.Range(StartSht.Cells(i,1),StartSht.Cells(GetLastRowInColumn(StartSht,C),1))= GetFilenameWithoutExtension(objFile.Name)
End If
i = GetLastRo wInSheet(StartSht)+ 1
结束
下一个ws
'(6)
'关闭,不保存对打开的文件的任何更改
。关闭SaveChanges:= False
结束
结束如果
'(7)
'移动到下一个文件
下一个objFile
' on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1'将查看器带到主文件的顶部
End Sub
'(8)
'获取所有从单元格开始的唯一列值c
函数GetValues(ch As Range,可选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))。单元格
'如果此列中没有值,则返回一个空字典
'如果此列中没有值,则dataRange将从* ch上的行
'*开始,结束于ch
如果(dataRange.Row =(ch.Row - 1))And(dataRange.Rows.count = 2)And(Trim(ch.Value)=)然后
GoTo Exit_Function
结束如果
对于每个单元格在dataRange.Cells
theValue = Trim(cell.Value)
如果Len(theValue)= 0然后
theValue = none
End If
'exclude
如果不是IsMissing(vSplit)然后
splitValues = Split(theValue,;)
theValue = splitValues(0)
End If
' ,
如果不是IsMissing(vSplit)然后
splitValues = Split(theValue,,)
theValue = splitValues(0)
如果
如果不是dict.exists(theValue)然后
dict.Add theValue,thevalue
End If
下一个单元格
Exit_Function:
设置GetValues = dict
结束函数
'(9)
'在行上找到一个标题:返回Nothing,如果没有找到
函数HeaderCell(rng As Range,sHeader As String)As Range
Dim rv As Range,c As Range
对于每个c在rng.Parent.Range(rng,rng.Parent.Cells(rng.Row,Columns.count).End(xlToLeft))。Cells
'如果包含某些字符串holder或cutting tool,则复制单元格值
如果Trim(c.Val ue)= sHeader然后
'如果InStr(c.Value,sHeader)<> 0然后
设置rv = c
退出
结束如果
下一步c
设置HeaderCell = rv
结束函数
'(10)
函数GetLastRowInColumn(theWorksheet As Worksheet,col As String)
使用theWorksheet
GetLastRowInColumn = .Range(col& .Rows.count).End(xlUp).Row
End
结束函数
'(11)
函数GetLastRowInSheet(作为工作表的工作表)
Dim ret
使用该工作表
如果Application.WorksheetFunction.CountA(。细胞) 0然后
ret = .Cells.Find(什么:=*,_
之后:=。范围(A1),_
LookAt:= xlPart,_
LookIn:= xlFormulas,_
SearchOrder:= xlByRows,_
SearchDirection:= xlPrevious,_
MatchCase:= False).Row
Else
ret = 1
结束如果
结束
GetLastRowInSheet = ret
结束函数
'(12)
'获取没有扩展名的文件名
函数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
结束函数
解决方案解决方案:
'(8)
'得到t他从具有指定标题的列的值
函数GetValues(ch As Range,可选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))。单元格
'如果此列中没有值,则返回一个空字典
'如果有在此列中没有值,dataRange将从行上的
'*开始,并以ch
结束If(dataRange.Row =(ch.Row - 1))And(dataRange.Rows .count = 2)和(Trim(ch.Value)=)然后
GoTo Exit_Function
结束如果
对于每个单元格在dataRange.Cells
计数器= counter + 1
theValue = Trim(cell.Value)
如果Len(theValue)= 0然后
theValue =
End If
'排除;之后的任何信息
如果不是IsMissing(vSplit)然后
splitValues = Split(theValue,;)
theValue = splitValues(0)
End If
' ,
如果不是IsMissing(vSplit)然后
splitValues = Split(theValue,,)
theValue = splitValues(0)
如果
如果不是dict.exists(theValue)然后
dict.Add counter,thevalue
End If
下一个单元格
Exit_Function:
设置GetValues = dict
结束功能
Explanation of code:
I have code that takes information from under two specific column headers in opening files and prints them to a masterfile. It prints information to my masterfile into column 3, then column 2, then column 1 based on the number of cells is in column 3. The columns 1, 2 and 3 should always be the same length (spaces included)
I currently use a GetValue function which finds a specific header such as HOLDER, and grabs all of the values under it from the last occupied row up to, but not including, the header HOLDER. It omits any duplicates.
The problem is that I need to have the duplicates in the sheet. The reason is that the 2nd and 3rd column values correspond to each other. So if a duplicate does not print to column 3, that doesn't mean there is a duplicate in column 2.
Example:
3 4 2 4 1 7 *next file* 1 9 7 6
would become
3 4 2 7 1 9 *next file* 1 6 7
(column 2 is shifted upward due to the omitting of the repeat value "4". The 1 in column 1 is not omitted because it only omits duplicates that are within the same opened file in the same column)
Thus, I do not get the information I need for that duplicate (using my example, that 2 and 4 should correspond not 2 and 7), and my column alignment is thrown off.
Any ideas how I can go about fixing this please?
Uses the GetValues function:
'(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 Function:
'(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
FULL CODE:
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
解决方案SOLUTION:
'(8) 'Get the Values from columns with specified headers 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
这篇关于VBA - 更改省略副本以允许重复的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!