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

はい、1つのセルにのみ配列を割り当てます。次に、最初の値のみがコピーされます。
配列を適切なサイズの範囲に割り当てる必要があります。これはで行うことができますRange.Resize。この場合も、Excelは配列を2次元配列（行列）として扱い、1次元のみの場合、これは常に最初の行として表示されます。これを垂直範囲にコピーすると、各セルには配列の同じ最初の要素が含まれます。
垂直範囲の場合、配列/仮想マトリックスを転置する必要があります。 

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 に答える