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

我在第Unknown Run time error行

处收到

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

错误

谢谢，

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

字典键分配行明智

1 个答案: