字典鍵分配明智的

Question

我有詞典對象Dic1，Dic2，其中的項目是一個字母表。說

 Dic1(10)= A 
    Dic1(111)= B 
    Dic1(12)= C like this. 


    Dic2(125)= A 
    Dic2(131)= B 
    Dic2(126)= C like this. 

現在我將嘗試通過以下在Excel中的行（第3列起）的循環來分配自己的鑰匙，但不是所有的按鍵都得到複製。

objSheet2.Range("C"&nRow).Value=Dic1.Keys() Or(condition wise any of the assignment 
    will be executed) 

    objSheet2.Range("C"&nRow).Value=Dic2.Keys() 

但只有第一個Key值被複制，忽略了其他值。你能告訴我的代碼中有什麼Bug嗎？

編輯

Option Explicit 

Class cP 
Public m_sRel 
Public m_dicC 
    Private Sub Class_Initialize() 
    m_sRel  = "Child" 
    Set m_dicC = CreateObject("Scripting.Dictionary") 
    End Sub 

    Public Function show() 
    show = m_sRel & " " & Join(m_dicC.Keys) 
    End Function 

End Class 

Dim objSheet1,objSheet2,TotalRows,TotalcolCopy,strPathExcel1 
'Dim oFS : Set oFS = CreateObject("Scripting.FileSystemObject") 
Dim oXls : Set oXls = CreateObject("Excel.Application") 
'Dim aData ': aData = oWb.Worksheets(1).Range("$A2:$C10") 
Dim dicP : Set dicP = CreateObject("Scripting.Dictionary") 
Dim nRow,nP,sKeys 

strPathExcel1 = "D:\WIPData\AravoMacro\Finalscripts\A.xlsx" 
oXls.Workbooks.open strPathExcel1 
'oXls.Workbooks.Open(oFs.GetAbsolutePathName("A.xlsx")) 
Set objSheet1 = oXls.ActiveWorkbook.Worksheets("WingToWingMay25") 
Set objSheet2 = oXls.ActiveWorkbook.Worksheets("ParentChildLink") 


TotalRows=oXls.Application.WorksheetFunction.CountA(objSheet1.Columns(1)) 
TotalcolCopy=oXls.Application.WorksheetFunction.Match("Parent Business Process ID", objSheet1.Rows(3), 0) 

objSheet1.Range(objSheet1.Cells(4,1),objSheet1.Cells(TotalRows,TotalcolCopy)).Copy(objSheet2.Range("A1")) 
objSheet2.Range(objSheet2.Cells(1,2),objSheet2.Cells(TotalRows,TotalcolCopy-1)).Delete(-4159) 
'Dim aData : aData=objSheet2.Cells.SpecialCells(12)'xlCellTypeVisible 

Dim aData : aData = objSheet2.Range("A1:B"&TotalRows-3) 

'MsgBox(LBound(aData, 1)&"And"&UBound(aData, 1)) 

    For nRow = LBound(aData, 1) To UBound(aData, 1) 

    Set dicP(aData(nRow, 1)) = New cP 
    'Set dicP(aData(nRow, 2)) = New cP 

    Next 
    'objSheet2.Cells.ClearContents'To clear all the previous contenets of the sheet#2 
    'sKeys=dicP.Keys 
    'objSheet2.Range("A1").Resize(dicP.Count) = oXls.Application.Transpose(sKeys) 
    'MsgBox(dicP.Count&":"&UBound(aData, 1)&":"&LBound(aData, 1)) 
    For nRow = LBound(aData, 1) To UBound(aData, 1) 

     If aData(nRow, 1) = aData(nRow, 2) Then 
      dicP(aData(nRow, 1)).m_sRel = "Parent" 
     Else 
      If dicP.Exists(aData(nRow, 2)) Then 

      dicP(aData(nRow, 2)).m_dicC.Add aData(nRow, 1), 0  '(aData(nRow, 1)) = 0 

      End If 
     End If 

    Next 

    objSheet2.Cells.ClearContents'To clear all the previous contenets of the sheet#2 

    nRow=1 
    For Each nP In dicP.Keys() 

    objSheet2.Cells(nRow,1).Value=nP 
    objSheet2.Cells(nRow,2).Value=dicP(nP).m_sRel 
    objSheet2.Range("C"&nRow).Resize(1+ UBound(dicP(nP).m_dicC.Keys()) + 1).Value=dicP(nP).m_dicC.Keys() 
    'Range("C" & nRow).Resize(1, UBound(d.Keys()) + 1).Value = d.Keys() 
    nRow=nRow+1 
    Next 

我在該行objSheet2.Range("C"&nRow).Resize(1+ UBound(dicP(nP).m_dicC.Keys()) + 1).Value=dicP(nP).m_dicC.Keys()

感謝得到一個錯誤的Unknown Run time error，

Answer 1

是的，你分配一個數組只有一個細胞。然後只複製第一個值。
您必須將數組分配到正確大小的範圍。這可以通過Range.Resize完成。 然後Excel再次將數組視爲一個二維數組（矩陣），並且如果它只是一維的，這將始終被視爲第一行。如果將其複製到垂直範圍內，則每個單元格將具有相同的陣列第一個元素。
對於垂直範圍，你要轉你的陣列/虛擬矩陣：

Sub test() 
    Dim d 
    Dim nRow As Long 

    nRow = 3 
    Set d = CreateObject("Scripting.Dictionary") 
    d(1) = "A" 
    d(2) = "B" 
    d(17) = "C" 
    d(32) = "F" 

    ' horizontal: 
    Range("C" & nRow).Resize(1, UBound(d.Keys()) + 1).Value = d.Keys() 

    ' vertical insert needs the data transformed 
    Range("C" & nRow).Resize(UBound(d.Keys()) + 1).Value = WorksheetFunction.Transpose(d.Keys()) 

End Sub 

爲了您的編輯，你可能首先需要糾正("C"&nRow)到("C" & nRow)。這些空間是必需的。
另一個錯誤是Resize(1 + ... + 1)，所以你加了+2，但是這不應該引發錯誤。