VB6.0用掲示板の過去のログ(No.1)−VBレスキュー(花ちゃん)
[記事リスト] [新規投稿] [新着記事] [ワード検索] [過去ログ] [管理用]

投稿日： 2002/12/18(Wed) 14:23
投稿者： 秋風
Ｅメール：
ＵＲＬ：
タイトル： Excelがタスクに残る現象について

こんにちは。

　質問なのですが、下記のコードで、csvファイルをエクセルに
変換しているのですが、1MBくらいのファイルになると、Excelが
タスクに残ってしまいます。(それ以下は、タスクには残りません
が）ずっと考えていましたが、どうにも
対策が思いつきません。どなたかお分かりの方、下記のコードで、
不備な点を教えて下さい。申し訳ない質問ですが、お願いします。
m(_ _)m
Private Sub Output_Excel_cmd_Click()

    On Error GoTo Err_
    Dim xlApp As excel.Application
    Dim xlBook As excel.Workbook
    Dim xlSheet As excel.Worksheet
    Dim aaa As String
    Dim bbb As String
    Dim ccc As String
    Dim ddd As String
    Dim eee As String
    Dim fff As String
    Dim ggg As String
    Dim hhh As String
    Dim lngline As Long
    Dim introw As Integer
    Dim strlst As String
    Dim strday As String
    Dim strtime As String
    Dim intflag As Integer
    Dim intfileno As Integer
    Dim iii As String
    Dim strid As String
    Dim iii_1 As String
    Dim kkk As String
    Dim lngfline As String
    Dim strpn As String
    Dim strpn_1 As String
    Dim strpn_2 As String
    Dim inticheck As Integer
    Dim intscheck As Integer
    Dim intdcheck As Integer
    
    Screen.MousePointer = vbHourglass
    intfileno = FreeFile()
    lngline = 1
    strlst = ファイル名lst.Text
    strpn_1 = RightB(strlst, 24)
    strpn_2 = LeftB(strpn_1, 2)
    
    Select Case strpn_2
    Case "I"
        strpn = "abc"
    Case "J"
        strpn = "etd"
    Case "K"
        strpn = "agd"
    Case "B"
        strpn = "gee"
    End Select
    
    If strlst = Empty Then
        MsgBox "出力したいファイルを選んで下さい。", vbCritical + vbOKOnly, "警告"
        Screen.MousePointer = vbDefault
        Exit Sub
    Else
        Open strlst For Input As #intfileno
        Set xlApp = New excel.Application
        Set xlBook = xlApp.Workbooks.Add
        Set xlSheet = xlBook.Worksheets(1)
        
        With xlApp
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
        With xlSheet
            .Cells(2, 1).Value = "a："
            .Cells(2, 6).Value = "g："
            .Cells(2, 8).Value = strpn
            .Cells(3, 1).Value = "c："
            .Cells(3, 6).Value = "d："
            .Cells(4, 1).Value = "e"
            .Cells(4, 2).Value = "f"
            .Cells(4, 3).Value = "gf"
            .Cells(4, 4).Value = "i"
            .Cells(4, 5).Value = "h"
            .Cells(4, 6).Value = "i"
            .Cells(4, 7).Value = "b"
            .Cells(4, 8).Value = "z"
            .Cells(4, 9).Value = "t"
            .Cells(4, 10).Value = "fa"
            .Cells(4, 11).Value = "fe"
            .Cells(4, 12).Value = "wd"
            .Cells(4, 13).Value = "qe"
        End With
        
        Call Bord_C(xlSheet, 2, 1)
        Call Bord_C(xlSheet, 2, 6)
        Call Bord_C(xlSheet, 3, 1)
        Call Bord_C(xlSheet, 3, 6)
        xlSheet.Range("A4:M4").Font.Bold = True
                                                    
                                                    
        Do While Not EOF(1)
            Line Input #intfileno, aaa
            bbb = Trim(LeftB(aaa, 14))
            ccc = Trim(MidB(aaa, 15, 16))
            ddd = Trim(MidB(aaa, 31, 22))
            eee = Trim(MidB(aaa, 53, 16))
            fff = Trim(MidB(aaa, 69, 12))
            hhh = LeftB(bbb, 2)
            intdcheck = InStr(ddd, "e")
            
            If intdcheck <> 0 Then
                ddd = "'" & ddd
            End If
            
            If hhh <> "*" And hhh <> "" Then
                
                If intflag = 0 Then
                    xlSheet.Cells(lngline + 4, 1).Value = bbb
                    xlSheet.Cells(lngline + 4, 2).Value = ccc
                    xlSheet.Cells(lngline + 4, 3).Value = eee
                   'xlSheet.Cells(lngline + 4, 9).Value = fff
                End If
                
                If NGflag = True Then
                        
                        If fff <> "NG" And fff <> "LO" And fff <> "HI" Then
                            
                            xlSheet.Cells(lngline + 4, 14 + introw).Value = ddd
                        End If
                    
                Else
                    
                    If fff = "NG" Or fff = "LO" Or fff = "HI" Then
                            With xlSheet.Cells(lngline + 4, 14 + introw).Interior
                                .ColorIndex = 3
                                .Pattern = xlSolid
                            End With
                    End If
                        xlSheet.Cells(lngline + 4, 14 + introw).Value = ddd
               End If
                
            Else
                ggg = MidB(aaa, 7, 22)
                strtime = MidB(aaa, 49, 10)
                iii = LeftB(ggg, 16)
                strid = MidB(aaa, 33, 8)
                inticheck = InStr(strid, "abd")
                
                If lngfline = "" Then lngfline = lngline

                If inticheck <> 0 Then
                
                    If intflag = 0 Then
                        iii_1 = RightB(strid, 2)
                        xlSheet.Cells(3, 3) = iii_1
                    End If
                    
                End If
                
                intscheck = InStr(ggg, "(")
                
                If intscheck = 0 Then
                    If ggg Like "******-****" Then
                        xlSheet.Cells(4, 14 + introw).Value = strtime
                        
                        If intflag = 0 Then
                            strday = MidB(aaa, 31, 16)
                            With xlSheet
                                .Cells(2, 3).Value = ggg
                                .Cells(3, 8).Value = "'" & strday
                            End With
                        End If
                    
                    ElseIf hhh = "" Then
                        If intflag = 0 Then intflag = 1
                        introw = introw + 1
                        lngline = 0
                        
                    End If
                End If
            End If
                lngline = lngline + 1
        Loop
        
        xlApp.Intersect(xlSheet.UsedRange, xlSheet.Range("4:65536")).Borders.LineStyle = xlContinuous
        Close #intfileno
    End If
            
    Dim t_gyou As Long
    Dim i As Long
    t_gyou = lngfline - 1

    For i = 1 To t_gyou
        kkk = "N" & i + 4 & ":" & "IV" & i + 4

        With xlSheet
            .Cells(i + 4, 5).Value = "=Min(" & kkk & ")"
            .Cells(i + 4, 6).Value = "=MAX(" & kkk & ")"
            .Cells(i + 4, 10).Value = "=AVERAGE(" & kkk & ")"
            .Cells(i + 4, 11).Value = "=STDEV(" & kkk & ")"
        End With
    Next i
    
    xlBook.VBProject.VBComponents.Import App.Path & "\Module3.bas"

    With xlSheet
            .Range("J5:J500").NumberFormatLocal = "0.000"
            .Range("K5:K500").NumberFormatLocal = "0.000"
            .Range("L5:L500").NumberFormatLocal = "0.000"
            .Range("M5:M500").NumberFormatLocal = "0.000"
            .Range("D5:D500").HorizontalAlignment = xlCenter
    End With
                
    With xlApp
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Visible = True
    End With
        
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    Call Clear_cmd_Click
    Screen.MousePointer = vbDefault
    
    Exit Sub
    
Err_:
    MsgBox Err.Description, vbCritical + vbOKOnly, "警告"
    
    Close #intfileno
    xlApp.Quit
    
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Screen.MousePointer = vbDefault
    
End Sub

- 関連一覧ツリー （★ をクリックするとツリー全体を一括表示します）
- 返信フォーム （この記事に返信する場合は下記フォームから投稿して下さい）

- Web Forum -