2

我有字典对象 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 值被复制，忽略另一个。你能告诉我代码中的错误是什么吗？

编辑

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

我收到一条错误Unknown Run time error消息objSheet2.Range("C"&nRow).Resize(1+ UBound(dicP(nP).m_dicC.Keys()) + 1).Value=dicP(nP).m_dicC.Keys()

谢谢，

4

1 回答 1

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，但这不应引发错误。

于 2012-12-21T11:55:30.267 回答