| |
ブーちゃん さん、おはようございます。
フォーム(UserForm1)にコマンドボタン(CommandButton1)とリストボックス(ListBox1)を配置
フォームをダブルクリックしてフォームのモジュールに以下を記述。
(Private Sub UserForm_Click()が自動生成されたら消去)
'↓ここから============================================================
Dim Ipath As String 'フォルダ名はグローバル変数にしておく。
Private Sub CommandButton1_Click()
Dim wb As Workbook
On Error GoTo ErrOut1
'
If MsgBox(Me.ListBox1.Text & "をチェックしますか？", vbYesNo) = vbYes Then
Set wb = Workbooks.Open(Ipath & Me.ListBox1.Text)
'内容をチェックするSubに移動
Calc1 wb
With wb
.Saved = True
.Close
End With
'
Set wb = Nothing
'フォームを閉じる
Me.Hide
End If
Fgate:
Exit Sub
'////////
ErrOut1:
'エラーにより中断
MsgBox Error(Err), vbExclamation, Err
Resume Fgate
End Sub
Private Sub ListBox1_Change()
'ListBox1のIndexが１以上でCommandButton1のEnabledがTrue(使えるようになる)
CommandButton1.Enabled = (ListBox1.ListIndex >= 0)
End Sub
Private Sub UserForm_Activate()
Dim Ifile As String, CC%
On Error GoTo ErrOut2
'リストボックスにファイル名追加
Ipath = "C:\EXCEL全集\" 'パス名指定
Ifile = Dir(Ipath & "*.xls")
Do Until Ifile = ""
Me.ListBox1.AddItem Ifile
Ifile = Dir '引き続き検索
Loop
'ファイル名を指定するまではCommandButton1を使えなくする
CommandButton1.Enabled = False
Fgate:
'することがあればここに書く
Exit Sub
'////////
ErrOut2:
'エラーにより中断
MsgBox Error(Err), vbExclamation, Err
Resume Fgate
End Sub
'↑ここまで============================================================
標準モジュール(Module)を挿入して、以下を記述
'↓ここから============================================================
Option Explicit
Sub MAIN()
'フォームを表示
UserForm1.Show
Unload UserForm1
End Sub
Sub Calc1(wb As Workbook)
' Private Sub() ←名前がないとエラーになる
Dim RR&, Rmax&, Rpos&, II%, Res$
Dim ws(1 To 2) As Worksheet
'全部Select Caseで分岐しました。
Set ws(1) = ThisWorkbook.Worksheets("Sheet4")
ws(1).Cells.Clear 'Sheet4を初期化
Rpos& = 0 '書き出すときは上詰めで
'開始
On Error Resume Next
'wbはコマンドボタンをクリックして開いたブック(オブジェクト変数)
'このSubをCallするときに引数として渡される。
'『Sheet8&9』を検索ということ？
Set ws(2) = wb.Worksheets("Sheet8&9")
On Error GoTo 0
'『Sheet8&9』というシートが無かったらその後の処理は無し
If Not ws(2) Is Nothing Then
With ws(2).UsedRange
Rmax& = .Cells(.Count).Row
End With
For RR& = 8 To Rmax&
'AFが0以外の時
With ws(2)
If .Cells(RR&, 32).Value <> 0 Then
'↑RR&のループの外に書いたら、行番号が0になるので必ずエラー
'改行しないときは _ ははずすこと
Res$ = "分岐対象外" 'これが結果に表示されたら分岐の定義ミス
Select Case .Cells(RR&, 13).Value & .Cells(RR&, 14).Value
Case "A1":
Select Case .Cells(RR&, 11).Value
Case 1
Select Case .Cells(RR&, 18).Value
Case 0: Res$ = "不具合A" 'エラー内容
Case 1: Res$ = "" '何も表示しない
Case Else: Res$ = "1A1_定義漏れ" 'エラー内容
End Select
Case 2
Select Case .Cells(RR&, 18).Value
Case 0: Res$ = "不具合B" 'エラー内容
Case 1: Res$ = "" '何も表示しない
Case Else: Res$ = "2A1_定義漏れ" 'エラー内容
End Select
Case Else
'.Cells(RR&, 11).Value = 1 または .Cells(RR&, 11).Value = 2 を満たさなかった
Res$ = "?A1_定義漏れ" 'エラー内容
End Select
Case Else
'.Cells(RR&, 13).Value = "A" かつ .Cells(RR&, 14).Value = 1を満たさなかった
Res$ = "???_定義漏れ" 'エラー内容
End Select
End If
'エラー内容が入っていたら
If Res$ <> "" Then
Rpos& = Rpos& + 1
For II% = 1 To 3
ws(1).Cells(Rpos&, II%).Value = _
.Cells(RR&, II% + 3).Value
Next
With ws(1).Cells(Rpos&, 4)
.Value = Res$
If InStr(Res$, "定義漏れ") > 0 Then
.EntireRow.Interior.ColorIndex = 44
Else
.EntireRow.Font.ColorIndex = 3
End If
.Offset(0, 1).Value = RR& '行番号
End With
End If
End With
Next
End If
End Sub
'↑ここまで============================================================
|
|
りん
- 03/11/30(日) 10:19 -
