| |
ブーちゃん さん、おはようございます。
> 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
こんな感じです。
細かな部分にわからないところが多いので、お望みの動作を一通り組み込んだものにしてみました。
|
|
りん
- 03/11/24(月) 10:03 -
