使用VBA收集到Excel中的VBA值

Question

我想使用VBA代碼將值複製到Excel工作表中。我一直在嘗試使用字典（在我的函數（8）中使用並在第（3）和（4）節中使用）。當我把它設置成字典時，所有的東西都被關掉了，所以我把字典變成了一個集合。現在問題是行d.Resize(dict.count, 1).Value = Application.Transpose(dict.count)（在第3節和4），因爲它正在計數值並輸出值的數量而不是值的名稱。

我認爲我需要將它更改爲更類似於d.Resize(dict.count, 1).Value = Application.Transpose(VariantArray)的東西，但我不知道如何定義鍵和值，因爲我沒有打印特定範圍，而是顯示特定標題下的任何內容。

這是一個很難說的話，所以如果我沒有足夠清楚地解釋它，可以隨意要求我更好地解釋它，我會盡力讓你走得更遠。

這是我的代碼，非常感謝任何幫助！

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 

Answer 1

既然你希望所有的價值，而不僅僅是一個獨特的名單中，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 

Answer 2

要獲得使用集合對象的唯一項目，你需要一個關鍵。例如：

這將讓唯一身份：

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