字典

最新推荐文章于 2022-12-20 11:34:18 发布

子龙奶爸

最新推荐文章于 2022-12-20 11:34:18 发布

阅读量257

点赞数

分类专栏： VBA 文章标签： string function integer object date each

本文链接：https://blog.csdn.net/zhaojianmingking/article/details/5408952

版权

VBA 专栏收录该内容

6 篇文章 0 订阅

订阅专栏

'******************************************************************************
'* プロシージャ名:UpdateGArrPersonSetBySetting
'* 記述:担当者の取得
'* @version $Date$ $Revision$ 説明
'* 更新履歴 001    2010/02/25 新規作成(趙建明)
'******************************************************************************
Function GetPersonsFromOutSheet(ArrPersons() As String) As Integer
    Dim ICount As Long
    Dim i As Long
    Dim WsOut As Worksheet
    Dim ILength As Long
    Dim IHiddenLen As Long
    GetPersonsFromOutSheet = 0
    '全進捗情報シートをチェック
    If Not ChkHaveSheet(GALLSCHEDULESHEETNAME) Then
            ReDim ArrPersons(0 To 0) As String
        Exit Function
    End If
    Set WsOut = Worksheets(GALLSCHEDULESHEETNAME)
    '全進捗情報データをチェック
    ILength = WsOut.Cells(Rows.Count, 2).End(xlUp).Row
    ICount = ILength - ISTARTLINE + 1
    IHiddenLen = WsOut.Cells(Rows.Count, 6).End(xlUp).Row
    'データはある
    If ICount > 0 And IHiddenLen > 1 Then
        Dim ObjDic As Object, RngCell As Range
        Dim RngTemp As Range
        With WsOut
            Set RngTemp = .Range("F2:F" & IHiddenLen)
        End With
        Set ObjDic = CreateObject("Scripting.Dictionary")
        On Error Resume Next
        For Each RngCell In RngTemp
            If RngCell.Text <> "" Then
            ObjDic.Add RngCell.Text, RngCell.Text
            End If
        Next RngCell
        Dim VTemp As Variant
        VTemp = ObjDic.keys
        ICount = ObjDic.Count
        If ICount > 0 Then
            GetPersonsFromOutSheet = ICount
            ReDim ArrPersons(0 To ICount - 1) As String
            '担当者は配列に保存する
            For i = 0 To ICount - 1
                ArrPersons(i) = VTemp(i)
            Next i
        End If
        On Error GoTo 0
    Else
        ReDim ArrPersons(0 To 0) As String
    End If
End Function