文件读入

'******************************************************************************
'* プロシージャ名:CmdFilePath_Click
'* 記述:「参照…」ボタン[クリック]処理
'* @version $Date$  $Revision$  説明
'* 更新履歴  001    2010/02/25  新規作成(趙建明)
'******************************************************************************
Private Sub CmdFilePath_Click()
    'ChDrive "c"
    Dim StrFileToOpen As String
    ChDir "c:/"
    'ダイアログを表示
    StrFileToOpen = Application _
    .GetOpenFilename("Text Files (*.xls;*.xlsx), *.xls;*.xlsx")
    'パスを取得
    If StrFileToOpen <> "False" Then
        TxtFilePath.Value = StrFileToOpen
    End If
End Sub

 

 

'******************************************************************************
'* プロシージャ名:CheckFileHead
'* 記述:読込ファイルヘッダチェック処理
'* @version $Date$  $Revision$  説明
'* 更新履歴  001    2010/02/25  新規作成(趙建明)
'******************************************************************************
Function CheckFileHead(ArrStrOpenFileHead() As String) As Boolean
    Dim StrFilePath As String, IHeadLineNum As Long
    Dim WbSource As Workbook, RngTitle As Range
    Dim RngCell As Range, StrTemp As String
    Dim IArrLen As Long, StrSourceSheetName As String
    Dim ObjEx As Object, IsNoThatSheet As Boolean
   
    CheckFileHead = False
    StrFilePath = GetStrFilePath()
    IHeadLineNum = GetIHeadLineNum()
    StrSourceSheetName = GetSourceSheetName()
    Application.ScreenUpdating = False
    'excelを始動
    Set ObjEx = CreateObject("Excel.Application")
    Set WbSource = ObjEx.Workbooks.Open(StrFilePath, True, True)
    ReDim ArrStrOpenFileHead(0 To 0)
    'シートの存在チェック
    IsNoThatSheet = False
   
    If CheckOutSideSheet(WbSource, StrSourceSheetName) Then
        StrSourceSheetName = GetSourceSheetName()
        Set RngTitle = WbSource.Worksheets(StrSourceSheetName).Rows(IHeadLineNum).Cells
        IArrLen = 1
        With RngTitle
            'セルは空以外の場合、配列を保存する
            For Each RngCell In RngTitle
                StrTemp = RngCell.Text
                If StrTemp <> "" Then
                    ReDim Preserve ArrStrOpenFileHead(0 To IArrLen)
                    ArrStrOpenFileHead(IArrLen) = StrTemp
                    IArrLen = IArrLen + 1
                End If
            Next
        End With
    Else
        IsNoThatSheet = True
       
    End If
    WbSource.Close (False)
    ObjEx.Quit
    Application.ScreenUpdating = True
    'シート存在しない
    If IsNoThatSheet Then
        MsgBox (GetMsg("MSG081"))
        Exit Function
    End If
    'ファイルヘッダ列数が4以下
    If UBound(ArrStrOpenFileHead) < 4 Then
            MsgBox (GetMsg("MSG037"))
            Exit Function
    End If
   
    CheckFileHead = True
End Function