使用 VBA 将 collection 的 VBA 值转换为 Excel
VBA values of collection into Excel using VBA
我正在尝试使用 VBA 代码将值复制到 Excel sheet 中。我一直在尝试使用字典（如在我的函数 (8) 中使用并在 (3) 和 (4) 节中使用）。当我将它设置为字典时，一切都差了一个，所以我将字典更改为 collection。现在的问题是 d.Resize(dict.count, 1).Value = Application.Transpose(dict.count) 行（在 第 3 节和第 4 节 中），因为它正在计算值并输出值的数量而不是值的名称。
我想我需要将其更改为更类似于 d.Resize(dict.count, 1).Value = Application.Transpose(VariantArray) 的内容，但我不知道如何定义键和值，因为我不是在打印特定范围，而是在特定 [=29] 下显示的任何内容=].
这个想法很难表达，所以如果我没有足够清楚地解释它，请随时让我更好地解释它，我会试着带你更多地了解它。
这是我的代码，非常感谢任何帮助！
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder 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 RowLast As Long
Dim f As String
Dim dict As Object
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'turn screen updating off - makes program faster
Application.ScreenUpdating = False
'Application.UpdateLinks = 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")
'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)
'print file name to Column 1
'Open folder and file name, do not update links
Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
Set ws = WB.ActiveSheet
'(3)
'find CUTTING TOOL on the source sheet
Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
If Not hc Is Nothing Then
Set dict = GetNames(hc.Offset(1, 0))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
'add the values to the masterfile, column 3
d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)
End If
Else
'header not found on source worksheet
End If
'(4)
'find HOLDER on the source sheet
Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
If Not hc3 Is Nothing Then
Set dict = GetNames(hc3.Offset(1, 0))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
'add the values to the master list, column 2
d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)
End If
Else
'header not found on source worksheet
End If
'(5)
With WB
'print TDS information
For Each ws In .Worksheets
'print the file name to Column 1
StartSht.Cells(i, 1) = objFile.Name
'print TDS name from J1 cell to Column 4
With ws
.Range("J1").Copy StartSht.Cells(i, 4)
End With
i = GetLastRowInSheet(StartSht) + 1
'move to next file
Next ws
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'move to next file
Next objFile
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1
'(7)
End Sub
'(8)
'get all unique column values starting at cell c
Function GetNames(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
Set dict = New Collection
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
dict.Add v
End If
Next c
Set GetNames = 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
If Trim(c.Value) = sHeader 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
要使用 Collection 对象获取独特的项目，您需要一个 key。例如：
这将获得唯一性：
Sub MAIN()
Dim z As Collection, r As Range
Set r = Range("A1:A4")
Set z = GetNames(r)
msg = z.Count & vbCrLf
For i = 1 To z.Count
msg = msg & z.Item(i) & vbCrLf
Next i
MsgBox msg
End Sub
'get all unique column values starting at cell c
Function GetNames(ch As Range) As Collection
Dim dict As Collection, rng As Range, c As Range, v
Set dict = New Collection
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
On Error Resume Next
dict.Add v, CStr(v)
On Error GoTo 0
End If
Next c
Set GetNames = dict
End Function
由于您需要所有值，而不仅仅是一个唯一列表，因此将 Dictionary 代码更改为：
Function GetValues(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
Set dict = CreateObject("scripting.dictionary")
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 And Not dict.exists(v) Then
dict.Add c.Address, v
End If
Next c
Set GetValues = dict
End Function
然后使用 Items 数组，而不是 Keys 数组：
Set dict = GetValues(hc3.Offset(1, 0))
If dict.Count > 0 Then
Set d = StartSht.Cells(Rows.Count, hc1.Column).End(xlUp).Offset(1, 0)
'add the values to the master list, column 2
d.Resize(dict.Count, 1).Value = Application.Transpose(dict.items)
End If
我正在尝试使用 VBA 代码将值复制到 Excel sheet 中。我一直在尝试使用字典（如在我的函数 (8) 中使用并在 (3) 和 (4) 节中使用）。当我将它设置为字典时，一切都差了一个，所以我将字典更改为 collection。现在的问题是 d.Resize(dict.count, 1).Value = Application.Transpose(dict.count) 行（在 第 3 节和第 4 节 中），因为它正在计算值并输出值的数量而不是值的名称。
我想我需要将其更改为更类似于 d.Resize(dict.count, 1).Value = Application.Transpose(VariantArray) 的内容，但我不知道如何定义键和值，因为我不是在打印特定范围，而是在特定 [=29] 下显示的任何内容=].
这个想法很难表达，所以如果我没有足够清楚地解释它，请随时让我更好地解释它，我会试着带你更多地了解它。
这是我的代码，非常感谢任何帮助！
Option Explicit
Sub LoopThroughDirectory()
Const ROW_HEADER As Long = 10
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder 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 RowLast As Long
Dim f As String
Dim dict As Object
Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range
Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
'turn screen updating off - makes program faster
Application.ScreenUpdating = False
'Application.UpdateLinks = 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")
'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)
'print file name to Column 1
'Open folder and file name, do not update links
Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
Set ws = WB.ActiveSheet
'(3)
'find CUTTING TOOL on the source sheet
Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
If Not hc Is Nothing Then
Set dict = GetNames(hc.Offset(1, 0))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
'add the values to the masterfile, column 3
d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)
End If
Else
'header not found on source worksheet
End If
'(4)
'find HOLDER on the source sheet
Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
If Not hc3 Is Nothing Then
Set dict = GetNames(hc3.Offset(1, 0))
If dict.count > 0 Then
Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
'add the values to the master list, column 2
d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)
End If
Else
'header not found on source worksheet
End If
'(5)
With WB
'print TDS information
For Each ws In .Worksheets
'print the file name to Column 1
StartSht.Cells(i, 1) = objFile.Name
'print TDS name from J1 cell to Column 4
With ws
.Range("J1").Copy StartSht.Cells(i, 4)
End With
i = GetLastRowInSheet(StartSht) + 1
'move to next file
Next ws
'(6)
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'move to next file
Next objFile
'turn screen updating back on
Application.ScreenUpdating = True
ActiveWindow.ScrollRow = 1
'(7)
End Sub
'(8)
'get all unique column values starting at cell c
Function GetNames(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
Set dict = New Collection
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
dict.Add v
End If
Next c
Set GetNames = 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
If Trim(c.Value) = sHeader 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
要使用 Collection 对象获取独特的项目，您需要一个 key。例如：
这将获得唯一性：
Sub MAIN()
Dim z As Collection, r As Range
Set r = Range("A1:A4")
Set z = GetNames(r)
msg = z.Count & vbCrLf
For i = 1 To z.Count
msg = msg & z.Item(i) & vbCrLf
Next i
MsgBox msg
End Sub
'get all unique column values starting at cell c
Function GetNames(ch As Range) As Collection
Dim dict As Collection, rng As Range, c As Range, v
Set dict = New Collection
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
On Error Resume Next
dict.Add v, CStr(v)
On Error GoTo 0
End If
Next c
Set GetNames = dict
End Function
由于您需要所有值，而不仅仅是一个唯一列表，因此将 Dictionary 代码更改为：
Function GetValues(ch As Range) As Object
Dim dict As Object, rng As Range, c As Range, v
Set dict = CreateObject("scripting.dictionary")
For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
v = Trim(c.Value)
If Len(v) > 0 And Not dict.exists(v) Then
dict.Add c.Address, v
End If
Next c
Set GetValues = dict
End Function
然后使用 Items 数组，而不是 Keys 数组：
Set dict = GetValues(hc3.Offset(1, 0))
If dict.Count > 0 Then
Set d = StartSht.Cells(Rows.Count, hc1.Column).End(xlUp).Offset(1, 0)
'add the values to the master list, column 2
d.Resize(dict.Count, 1).Value = Application.Transpose(dict.items)
End If