投稿時間：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
|