Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


71882 / 76732 ←次へ | 前へ→

【9341】リストボックスで選択したファイルの内容チェック
回答  りん E-MAIL  - 03/11/30(日) 10:19 -

引用なし
パスワード
   ブーちゃん さん、おはようございます。

フォーム(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が1以上で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
'↑ここまで============================================================

1 hits

【9213】手に負えない ブーちゃん 03/11/24(月) 2:48 質問
【9216】Re:手に負えない りん 03/11/24(月) 10:03 回答
【9281】Re:手に負えない ブーちゃん 03/11/26(水) 17:13 質問
【9310】Re:手に負えない りん 03/11/27(木) 21:11 回答
【9314】Re:手に負えない ブーちゃん 03/11/28(金) 11:00 質問
【9341】リストボックスで選択したファイルの内容チ... りん 03/11/30(日) 10:19 回答
【9352】Re:リストボックスで選択したファイルの内... ブーちゃん 03/11/30(日) 16:31 質問
【9361】Re:リストボックスで選択したファイルの内... りん 03/11/30(日) 18:17 発言
【9377】Re:リストボックスで選択したファイルの内... ブーちゃん 03/12/1(月) 15:19 回答
【9400】Re:リストボックスで選択したファイルの内... りん 03/12/2(火) 23:22 回答
【9843】Re:リストボックスで選択したファイルの内... ブーちゃん 03/12/18(木) 14:16 質問
【9870】Re:リストボックスで選択したファイルの内... ブーちゃん 03/12/19(金) 15:38 お礼

71882 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free