Question

代码说明：

我的代码从打开文件中的两个特定列标题中获取信息，并将它们打印到主文件中。它将信息打印到我的主文件到第3列，然后是第2列，然后第1列基于第3列中的单元格数。列1,2和3应该始终是相同的长度（包括空格）

我目前使用GetValue函数找到一个特定的标题，例如HOLDER，并从最后一个占用的行中获取其下的所有值，但不包括标题HOLDER。它省略了任何重复。

问题是我需要在工作表中包含重复项。原因是第2和第3列值彼此对应。因此，如果副本未打印到第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

（由于省略了重复值“4”，第2列向上移动。第1列中的1不会被省略，因为它只省略同一列中同一个打开文件中的重复项）< / em>的

因此，我没有获得该副本所需的信息（使用我的示例，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

Answer 1

<强> 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 - 更改省略重复以允许重复

1 个答案: