Excel VBA質問箱 IV

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

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


72005 / 76732 ←次へ | 前へ→

【9216】Re:手に負えない
回答  りん E-MAIL  - 03/11/24(月) 10:03 -

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

> Excelで作成した1つのプログラムを用いて、複数のExcelファイル中の該当する行を検索するプログラムです。条件として、
> 1.ファイル中の検索対象の全行数はまちまちで、どれも8行目から開始するとします。
> 2.行検索する、Excelファイルの対象は、Cドライブの中のフォルダ「Excelファイ
>ル全集」中の、ExcelファイルのSheet8&9のみとします。
> 3.cells("AF").value =0の行は検索対象とせずに、はじき飛ばすものとします。

mainを実行、またはコマンドボタンのイベントからCallしてみてください。
Sub main()
  'コマンドボタンからこれを実行
  ActiveCell.Activate '97の時は必要
  Dim Ifile As String, wb As Workbook
  Ifile = Application.GetOpenFilename("XLSファイル (*.xls), *.xls")
  If Ifile = "FALSE" Then
   MsgBox "ファイル未選択", vbExclamation, "中断"
  Else
   Application.ScreenUpdating = False
   '
   Set wb = Workbooks.Open(Ifile)
   '
   Check8and9 wb 'チェックするSubをCall(引数は対象のブックです)
   '閉じる
   With wb
     .Saved = True
     .Close savechanges:=False
   End With
   Application.ScreenUpdating = True
  End If
End Sub

Sub Check8and9(wb As Workbook)
  Dim RR&, Rmax&, Rpos&, II%, Rec$
  Dim ws(1 To 2) As Worksheet
  '
  Set ws(1) = ThisWorkbook.Worksheets("Sheet4")
  ws(1).Cells.Clear 'Sheet4を初期化
  Rpos& = 0 '書き出すときは上詰めで
  '開始
  On Error Resume Next
  '『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以外の時
     If ws(2).Cells(RR&, 32).Value <> 0 Then
      With ws(2)
        Rec$ = .Cells(RR&, 11).Value & .Cells(RR&, 13).Value & _
           .Cells(RR&, 14).Value & .Cells(RR&, 18).Value
      End With
      '
      If Rec$ = "" Or Rec$ = "1A11" Then
      Else
        Rpos& = Rpos& + 1
        With ws(1)
         For II% = 1 To 3
           .Cells(Rpos&, II%).Value = _
            ws(2).Cells(RR&, II% + 3).Value
         Next
         With .Cells(Rpos&, 4)
           If Rec$ = "1A10" Then
            .Value = "不具合"
            .EntireRow.Font.ColorIndex = 3
           Else
            .Value = "定義漏れ"
            .EntireRow.Font.ColorIndex = 44
           End If
         End With
         'おまけ
         .Cells(Rpos&, 5).Value = RR& '元の行番号
        End With
      End If
     End If
   Next
   Set ws(2) = Nothing
  End If
  '結果表示
  ThisWorkbook.Activate
  ws(1).Activate
  Erase ws
End Sub

こんな感じです。
細かな部分にわからないところが多いので、お望みの動作を一通り組み込んだものにしてみました。
0 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 お礼

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