| |
返答ありがとうございます。
書いていませんでしたが、これはVBから
EXCEL.exeを起動してから、マクロを立ち上げています。
ソースは以下の通りです。
少し長いですが、申し訳ありません。
変数宣言をして、制御した場合ですが、もちろん
グローバル変数にしています。
Sub CsvHozon()
On Error GoTo ERR_EXIT
Application.ScreenUpdating = False '処理画面非表示
Application.DisplayAlerts = False '警告メッセージ非表示
Application.EnableEvents = False 'イベント発生させない
If RES = vbYes Then
fileMei = wsFileB
prgSeq = "0140"
If wsKakukbn = "EXCEL" Then
ChDir wsPass
myFName = Application.GetSaveAsFilename(fileMei, "CSVﾌｧｲﾙ End If
prgSeq = "0160"
If myFName <> "False" Then
prgSeq = "0180"
Len1 = Len(myFName)
'パス + ファイル名（拡張子なし）
NmyFName = Mid(myFName, 1, Len1 - 4)
'拡張子
KmyFName = Mid(myFName, Len1 - 3, Len1)
Len2 = Len(NmyFName)
'Len2 = LenB(StrConv(myFName, vbFromUnicode))
'最後の\の位置を確認
prgSeq = "0200"
For lLoopCnt = 1 To Len1 - 4
If Mid(myFName, lLoopCnt, 1) = "\" Then
wkIti = lLoopCnt
End If
Next lLoopCnt
'実際に入力されたファイル名を取得
prgSeq = "0220"
fileMei = Mid(NmyFName, wkIti + 1, 100)
'新規bookOpen
prgSeq = "0240"
Workbooks.Add
'シートの数
prgSeq = "0260"
shtCnt = ActiveWorkbook.Worksheets.Count
'ｼｰﾄ1削除
If ActiveWorkbook.Worksheets.Count > 1 Then
'ｼｰﾄ1削除
prgSeq = "0280"
ActiveWorkbook.Worksheets(1).Select
ActiveWindow.SelectedSheets.Delete
'新規bookの名前変更
prgSeq = "0300"
ActiveWorkbook.SaveAs Filename:=NmyFName & "temp2" & KmyFName, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
'新規ｴｸｾﾙにｼｰﾄｺﾋﾟｰ
prgSeq = "0320"
ThisWorkbook.Worksheets(1).Copy Before:=Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1)
'ｼｰﾄ削除
prgSeq = "0340"
For lLoopCnt = 2 To shtCnt
'Workbooks(fileMei & "temp2" & KmyFName).Worksheets(lLoopCnt).Delete
Workbooks(fileMei & "temp2" & KmyFName).Worksheets("Sheet" & lLoopCnt).Delete
Next lLoopCnt
Else
'シート1の名称変更
prgSeq = "0360"
ActiveWorkbook.Worksheets(1).Select
ActiveWorkbook.Sheets.Add
ActiveWorkbook.Worksheets(1).Select
ActiveWorkbook.Worksheets(1).Delete
'新規bookの名前変更
prgSeq = "0380"
ActiveWorkbook.SaveAs Filename:=NmyFName & "temp2" & KmyFName, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
'新規ｴｸｾﾙにｼｰﾄｺﾋﾟｰ
prgSeq = "0400"
ThisWorkbook.Worksheets(1).Copy Before:=Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1)
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(2).Select
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(2).Delete
End If
'画面のボタン削除
prgSeq = "0420"
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton1").Delete
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton2").Delete
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton3").Delete
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton4").Delete
'画面のﾍｯﾀﾞｰ削除
prgSeq = "0440"
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).Rows("1" & ":" & pgHdg - 1).Select
Selection.Delete Shift:=xlUp
Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).Range("A" & pgHdg).Select
'ﾏｸﾛは削除して保存
With Workbooks(fileMei & "temp2" & KmyFName).VBProject
For Each VBC In .VBComponents
Select Case VBC.Type
Case 1, 2, 3
.VBComponents.Remove VBC
Case 100
With VBC.CodeModule
.Deletelines 1, .Countoflines
End With
End Select
Next
End With
'エラーだった場合色を消す
Cells.Select
Selection.Interior.ColorIndex = xlNone
Range("A1").Select
'ｳｲﾝﾄﾞｳ枠の固定を解除
prgSeq = "0460"
ActiveWindow.FreezePanes = False
prgSeq = "0480"
If KmyFName = ".xls" _
Or KmyFName = ".XLS" Then
Workbooks(fileMei & "temp2" & KmyFName).Save
Workbooks(fileMei & "temp2" & KmyFName).Close
Else
Workbooks(fileMei & "temp2" & KmyFName).SaveAs Filename:=NmyFName & "temp2" & KmyFName, FileFormat _
:=xlCSV, CreateBackup:=False
Workbooks(fileMei & "temp2" & KmyFName).Close
End If
'上書き保存かどうかの確認
'上書き保存でない場合
If wsExcel <> NmyFName & KmyFName Then
'名称変更 (temp名、削除)
prgSeq = "0500"
strFile = Dir(NmyFName & KmyFName)
If strFile <> "" Then
Kill (NmyFName & KmyFName)
End If
prgSeq = "0520"
Name NmyFName & "temp2" & KmyFName As NmyFName & KmyFName
'tempﾌｧｲﾙ名変更
prgSeq = "0540"
strFile = Dir(wsBackupPass & wsFileA & wsKakutyo)
strFileB = Dir(wsBackupPass & wsFileA & "temp" & wsKakutyo)
prgSeq = "0560"
If strFile = "" _
And strFileB <> "" Then
Name wsBackupPass & wsFileA & "temp" & wsKakutyo As wsBackupPass & wsFileA & wsKakutyo
End If
'上書き保存の場合
Else
prgSeq = "0580"
strFile = Dir(wsBackupPass & wsFileA & wsKakutyo)
strFileB = Dir(wsBackupPass & wsFileA & "temp" & wsKakutyo)
If strFile <> "" Then
Kill (wsBackupPass & wsFileA & wsKakutyo)
End If
prgSeq = "0500"
Name NmyFName & "temp2" & KmyFName As wsBackupPass & wsFileA & wsKakutyo
End If
Application.EnableEvents = False 'イベント発生させない
'ThisWorkbook.Close
'ここです。
Application.Quit
End If
End If
Range("A" & pgHdg).Select
GoTo NORMAL_EXIT
''**********************************************************************
''エラールーチン設定
''**********************************************************************
ERR_EXIT:
'temp元に戻す
strFile = Dir(wsBackupPass & wsFileA & wsKakutyo)
strFileB = Dir(wsBackupPass & wsFileA & "temp" & wsKakutyo)
If strFile = "" _
And strFileB <> "" Then
Name wsBackupPass & wsFileA & "temp" & wsKakutyo As wsBackupPass & wsFileA & wsKakutyo
End If
retErrMsg = ""
retErrMsg = retErrMsg & " VB_Error Number:" & Err.Number & vbCrLf
retErrMsg = retErrMsg & " VB_Error Description:" & Err.Description & " " & _
"エラーファイル名 : 単品マクロ、 " & "エラー箇所 : " & "(CsvHozon)、" & prgSeq & " " & vbCrLf
MsgBox retErrMsg
ThisWorkbook.Close
''**********************************************************************
''正常終了
''**********************************************************************
NORMAL_EXIT:
Application.ScreenUpdating = True '処理画面表示
Application.DisplayAlerts = True '警告メッセージ表示
Application.EnableEvents = True 'イベント再発生
'Excel を閉じる
'Application.Quit
End Sub
|
|
nao
- 04/5/31(月) 12:36 -
