Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

12568 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【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


	【9213】手に負えない

ブーちゃん - 03/11/24(月) 2:48 -


	引用なし

	パスワード

Excelで作成した1つのプログラムを用いて、複数のExcelファイル中の該当する行を検索するプログラムです。条件として、　1.ファイル中の検索対象の全行数はまちまちで、どれも8行目から開始するとします。　2.行検索する、Excelファイルの対象は、Cドライブの中のフォルダ「Excelファイル全集」中の、ExcelファイルのSheet8&9のみとします。　3.cells("AF").value =0の行は検索対象とせずに、はじき飛ばすものとします。　リストボックスの中に在るファイルをマウスで選択して、釦を押下すると、「ファイルAの行検索をしますか？OK or No」と言うメッセージが出ます。「OK」を押下すると、　1.Cells(i, 11).value = 1&Cells(i, 13).value = A&Cells(i, 14).value =1&Cells(i,18).value = 1を満たせば、プログラム側Sheet4側には何も表示しません。　一方、　2.セル中の値；Cells(i, 11).value = 1&Cells(i, 13).value = A&Cells(i, 14).value =1&Cells(i, 18).value = 0を全て満たす行が存在すれば、対象行中のE,F,G列に書かれている内容を、プログラム側のSheet4側のA,B,C列に表示し、D列全てに「不具合」と表示し、全て文字は赤色とします。　　そして、 3.上記の2つの定義に当てはまらなければ、プログラム側のSheet4側の、上記で検索した「不具合」の下側画面部に、対象行中のE,F,G列に書かれている内容と、D列全てに「定義洩れ」のコメントを付け、全て橙色で表示する様にします。　以上の、ファイル中全ての行検索処理が終了したら、自動でSheet4に飛び、結果が表示されます。そこで、書いてみましたが・・・ Private Sub CommandButton1_Click()　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Call TestOkXOrNo(Workbooks("\C:Excelファイル全集.*.xls\").Worksheets("Sheet8&9")) 　 End Sub 　　　　　　 Sub TestOkXOrNo(ws As Worksheet, lngStartRow As Long, lngLastRow As Long, putCol As Byte) 　　If Not ws Is Nothing Then　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Dim union　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Dim i　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　For i = lngStartRow To lngLastRow　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　union = ws.Cells(i, 11) & ws.Cells(i, 13) & ws.Cells(i, 14) & ws.Cells(i, 18)　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　If union = "1A11" Then　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ws.Cells(i, putCol) = "記述せず"　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ElseIf union = "1A10" Then　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ws.Cells(i, putCol) = "不具合"　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Else　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ws.Cells(i, putCol) = "定義洩れ"　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　End If　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Next　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　End If　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 End Sub　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　この後が、続きません。


	【9216】Re:手に負えない

りん

- 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

こんな感じです。
細かな部分にわからないところが多いので、お望みの動作を一通り組み込んだものにしてみました。


	【9281】Re:手に負えない

ブーちゃん - 03/11/26(水) 17:13 -


	引用なし

	パスワード

どうも有難うございました。If Rec$ = "" Or Rec$ = "1A11"の様に、4つのセルの中を1つに組み合わせてしまった様ですが、
　Cells(i, 11).value = 1&Cells(i, 13).value = A&Cells(i,14).value = 1&Cells
(i, 18).value = 1の様な定義は、1つだけでなく、「不具合」の場合の定義も、複数在
ります。Select Caseを用いた場合、どの様に変更すれば良いでしょうか?
　又、くっつける方法も在る様ですが、　Cells(i, 11).value = 1&Cells(i, 13).value = A&Cells(i,14).value = 1&Cells(i, 18).value = 1を省略せずに、Dim
As Variantの様に変数定義する方法は在るのでしょうか?これは、4つの列のみだけで無く、5つの列のセルの値を定義する事もあるからです。


	【9310】Re:手に負えない

りん

- 03/11/27(木) 21:11 -


	引用なし

	パスワード

他にどんな定義があるのかわからないので分岐の一例です。

分岐の部分だけ修正したものです。mainは前回のままなので載せていません。
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)
　　　　　　　　　　 Select Case Rec$
　　　　　　　　　　　　Case "1A10"
　　　　　　　　　　　　　 .Value = "不具合A"
　　　　　　　　　　　　　 .EntireRow.Font.ColorIndex = 3
　　　　　　　　　　　　Case "1B10"
　　　　　　　　　　　　　 'たとえばM列の値がBの場合の分岐例
　　　　　　　　　　　　　 .Value = "不具合B"
　　　　　　　　　　　　　 .EntireRow.Font.ColorIndex = 3
　　　　　　　　　　　　Case Else
　　　　　　　　　　　　　 '定義漏れかつO列に×が入っているものの抽出例
　　　　　　　　　　　　　 If ws(2).Cells(RR&, 15).Value = "×" Then
　　　　　　　　　　　　　　　.Value = "定義漏れ×"
　　　　　　　　　　　　　　　.EntireRow.Font.ColorIndex = 44
　　　　　　　　　　　　　 Else
　　　　　　　　　　　　　　　.Value = "定義漏れ"
　　　　　　　　　　　　　　　.EntireRow.Font.ColorIndex = 44
　　　　　　　　　　　　　 End If
　　　　　　　　　　 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
こんな感じです。

条件を全て満たすかどうかについて、連結した文字列にして判定する方法以外ならば、And 演算子を使って論理積を求めればいいです。
Sub test()
　 Dim tf As Boolean, I As Integer
　 For I = 8 To 10
　　　tf = (Cells(I, 11).Value = 1) And _
　　　　　　(Cells(I, 13).Value = "A") And _
　　　　　　(Cells(I, 14).Value = 1) And _
　　　　　　(Cells(I, 18).Value = 1)
　　　If tf Then
　　　　 MsgBox "一致", vbInformation, I & "行目"
　　　Else
　　　　 MsgBox "不一致", vbInformation, I & "行目"
　　　End If
　 Next
End Sub

直接If文でも同じこと
Sub test()
　 Dim I As Integer
　 For I = 8 To 10
　　　'
　　　If (Cells(I, 11).Value = 1) And (Cells(I, 13).Value = "A") And _
　　　　 (Cells(I, 14).Value = 1) And (Cells(I, 18).Value = 1) Then
　　　　 MsgBox "一致", vbInformation, I & "行目"
　　　Else
　　　　 MsgBox "不一致", vbInformation, I & "行目"
　　　End If
　 Next
End Sub


	【9314】Re:手に負えない

ブーちゃん - 03/11/28(金) 11:00 -


	引用なし

	パスワード

とりあえず、書いてみましたが、この後が続きません。1つ１つLNを定義して、且つCase
毎に処理内容を書こうと思っているのですが、どうすれば良いでしょうか？
Sub Command Button1(wb As Workbook)
　 Dim RR&, Rmax&, Rpos&, II%, Rec$
　 Dim ws(1 To 2) As Worksheet
　 Dim PS(RR&) As Variant
Dim objWSH As Object
　　 Dim strPS　 As String
　　 Dim Ans
　　
　　Set objWSH = CreateObject("WScript.Shell")
　　On Error GoTo err_line
　　strPS = objWSH.SpecialFolders("\C:") & "\Excelファイル全集\" & _
　　　　　　　　　　Me.ListBox1.Text
　　　　
　　Ans = MsgBox(Me.ListBox1.Text & "をチェックしますか？", vbYesNo)
　　If Ans = vbYes Then Workbooks.Open strPS

err_line:
　　Select Case Err.Number
　　　　Case 0
　　　　Case 1004
　　　　　　MsgBox "ファイルがフォルダ中に存在しません"
　　　　Case Else
　　　　　　MsgBox Err.Number
　　End Select
　　Err.Clear
　　Set objWSH = Nothing
End Sub
　
　 Private Sub()
　 Dim LN1　As Boolean
　 Dim LN2　As Boolean
　 Dim LN15 As Boolean
　 Dim LN16 As Boolean
　
　
　 Dim PS　　As Long

LN1　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)’・・・(何も表示しない)
LN2　= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)’・・・(何も表示しない)
LN15　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)’・・・(不具合A)
LN16　= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)’・・・(不具合B)

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

For RR& = 8 To Rmax&　　　　
VntTmp(RR&) = Me("Cells.Count" & RR&+ 1).ListIndex + 1
　　Next RR&
　　Select Case Join(PS, "_")
　　Case Join(LN1, "_")
　　　　→何も表示しない
　　Case Join(LN2, "_")
　　→何も表示しない　
　　Case Join(LN16, "_")
　　　LN16 .Value = "不具合A"
EntireRow.Font.ColorIndex = 3
　　Case Join(LN17, "_")
　　LN17.Value = "不具合B"
EntireRow.Font.ColorIndex = 3
Case Else
'定義漏れ
If ws(2).Cells(RR&, 15).Value = "×"
Then.Value = "定義漏れ"
.EntireRow.Font.ColorIndex = 44
End If
　　End Select
End Sub


	【9341】リストボックスで選択したファイルの内容...

りん

- 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が１以上で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
'↑ここまで============================================================


	【9352】Re:リストボックスで選択したファイルの内...

ブーちゃん - 03/11/30(日) 16:31 -


	引用なし

	パスワード

違法なマルチサイトを使ってしまい、ビリーさんから、以下のコードの助言を頂き
ました。
LNの変数定義が、37種にも及び、検索定義の列が1つから5つとまちまちなので、　Case1;　LN1　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value
= "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)の
様にやるのは、難しいでしょうか？複数のセルの値を1つに纏めてしまうと、解り辛く成ってしまいます。余りKStepが大きいと、メモリを食ってしまうかもしれませんが、Case毎に、処理を書いた方が処理内容が解り易いです。御願い致します。
　りんさんにとって、それしか方法が無いのなら、この方法を試してみます。
Private Sub TEST1()

　　DIM i AS LONG
　　DIM 最終行 AS LONG
　　DIM ws(1 TO 2) AS WORKSHEET

　 Dim LN1　As Boolean
　 Dim LN2　As Boolean
　　Dim LN15 As Boolean
　　Dim LN16 As Boolean

　 Set ws(2) = WORKBOOKS("XXX.xls").Worksheets("Sheet8&9")
　 Set ws(1) = THISWORKBOOK.Worksheets("Sheet4")
　 ws(1).Cells.Clear 'Sheet4を初期化

　　FOR i=8 TO 最終行
　　　　' LN1,LN2,LN15,LN16の設定
　　　　' Sheet4への処理（要分岐）
　　NEXT i

END SUb

　ThisWorkBookのコード;
Private Sub Workbook_Open()
　　Dim objWSH As Object
　　Dim strPS　 As String
　　Dim Ans
　　Dim i As Long
　　
　　Set objWSH = CreateObject("WScript.Shell")
　　strPS = objWSH.SpecialFolders("\C:") & "\Excelファイル全集"

　　With Application.FileSearch
　　　　.LookIn = strPS
　　　　.Filename = "*.xls"
　　　　If .Execute(SortBy:=msoSortByFileName) > 0 Then
　　　　　　For i = 1 To .FoundFiles.Count
　　　　　　　　Worksheets(1).ListBox1.AddItem Dir(.FoundFiles(i))
　　　　　　Next
　　　　End If
　　End With
End Sub


	【9361】Re:リストボックスで選択したファイルの内...

りん

- 03/11/30(日) 18:17 -


	引用なし

	パスワード

▼ブーちゃんさん：
> 違法なマルチサイトを使ってしまい、ビリーさんから、以下のコードの助言を頂き
>ました。
　違法？

まず、前回の回答見てくれていますか？
Select Case の考え方を基本的に間違えている気がします。Caseごとに...の内容を見ると、Ifブロックで分岐する方法を言っているようにみえますが。
わからないときはヘルプにきちんと目をとおしてますか？

>Case毎に、処理を書いた方が処理内容が解り易いです。御願い致します。
　何にしても、分岐後の答えをはき出す関数を作って柔軟に対応したほうがよさそうなので。

前回のCalc1以下を次のコードに直して使ってください。

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&
　　　　 res$ = CheckDat(ws(2), RR&)
　　　　 If res$ <> "" Then
　　　　　　With ws(2)
　　　　　　　 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 With
　　　　 End If
　　　Next
　 End If
End Sub

'判定結果を返す関数
Function CheckDat(ws As Worksheet, RR&) As String
　 Dim res$ '結果の文字列
　 res$ = "分岐対象外" 'これが結果に表示されたら分岐の定義漏れの可能性大
　 With ws
　　　If .Cells(RR&, 32).Value = 0 Then
　　　　 res$ = ""
　　　Else
　　　　 'M列N列の条件判定より先に分岐したいものがあればこの上に
　　　　 If .Cells(RR&, 13).Value = "A" And .Cells(RR&, 14).Value = "1" Then
　　　　　　If .Cells(RR&, 11).Value = 1 Then
　　　　　　　 Select Case .Cells(RR&, 18).Value
　　　　　　　　　Case 0:　　res$ = "不具合A" 'エラー内容
　　　　　　　　　Case 1:　　res$ = "" '何も表示しない
　　　　　　　　　Case Else: res$ = "1A1_定義漏れ" 'エラー内容
　　　　　　　 End Select
　　　　　　ElseIf .Cells(RR&, 11).Value = 2 Then
　　　　　　　 Select Case .Cells(RR&, 18).Value
　　　　　　　　　Case 0:　　res$ = "不具合B" 'エラー内容
　　　　　　　　　Case 1:　　res$ = "" '何も表示しない
　　　　　　　　　Case Else: res$ = "2A1_定義漏れ" 'エラー内容
　　　　　　　 End Select
　　　　　　Else
　　　　　　　 res$ = "?A1_定義漏れ"　'エラー内容
　　　　　　End If
　　　　 Else
　　　　　　'AF=0,M=A,N=1ではない分岐を書きたければここに書く。
　　　　　　res$ = "???_定義漏れ"　'エラー内容
　　　　 End If
　　　End If
　 End With
　 '戻り値決定
　 CheckDat = res$
End Function

37種類の分岐の内容が差しさわりがなければ教えてください。
差しさわりがあるのなら、関数に分岐の例が入っていますので、順番に分岐を増やしてください。


	【9377】Re:リストボックスで選択したファイルの内...

ブーちゃん - 03/12/1(月) 15:19 -


	引用なし

	パスワード

　残りの定義は、以下の通りです。空欄は、まだ定まっていない定義です。

'何も表示しない定義'
LN1　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)
LN2　= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)
LN3 = (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 1)
LN4= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)
LN5 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)
LN6 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)
LN7= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 1)
LN8　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 1)
LN9　= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 1)
LN10　= (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 1)
LN11 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 1)
LN12
LN13
LN14

　　　 '不具合A・B・C・・・定義'
LN15　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN16　= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN17　= (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 0)
LN18　= (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 0)
LN19 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 0)

LN20　= (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN21　= (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "A") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 0)
LN22
LN23 = Cells(RR&, 13).Value = A
LN24 = (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN25 = (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN26 = (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 0)
LN27 = (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 0) And _ (Cells(RR&, 18).Value = 0)
LN28 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN29 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "B") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN30 = (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "C") And _ (Cells(RR&, 18).Value = 0)
LN31 = (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "C") And _ (Cells(RR&, 18).Value = 0)
LN32 = (Cells(RR&, 11).Value = 0) And _ (Cells(RR&, 13).Value = "D") And _ (Cells(RR&, 14).Value = 1) And _ (Cells(RR&, 18).Value = 0)
LN33 = (Cells(RR&, 11).Value = 1) And _ (Cells(RR&, 13).Value = "D")
LN34 = (Cells(RR&, 11).Value = 2) And _ (Cells(RR&, 13).Value = "D")
LN35
LN36
LN37


	【9400】Re:リストボックスで選択したファイルの内...

りん

- 03/12/2(火) 23:22 -


	引用なし

	パスワード

▼ブーちゃんさん：

前回のFunctionを以下のものに変更してください。

Function CheckDat(ws As Worksheet, RR&) As String
　 '長いと見づらいので変数（配列）に格納して処理
　 Dim c(1 To 5) As Variant, res$
　 With ws
　　　c(1) = .Cells(RR&, 11).Value
　　　c(2) = .Cells(RR&, 13).Value
　　　c(3) = .Cells(RR&, 14).Value
　　　c(4) = .Cells(RR&, 18).Value
　　　'c(5) = .Cells(RR&,　５番目条件の列番号).Value
　 End With
　 res$ = "分岐指定ミス"
　 '
　 '難しいことは考えず、ベタに分岐します。
　 If (c(1) = 1) And (c(2) = "A") And (c(3) = 1) And (c(4) = 1) Then
　　　res$ = "": 'LN1 何も表示しない定義
　 ElseIf (c(1) = 2) And (c(2) = "A") And (c(3) = 1) And (c(4) = 1) Then
　　　res$ = "": 'LN2 何も表示しない定義
　 ElseIf (c(1) = 1) And (c(2) = "A") And (c(3) = 0) And (c(4) = 1) Then
　　　res$ = "": 'LN3 何も表示しない定義
　 ElseIf (c(1) = 1) And (c(2) = "A") And (c(3) = 1) And (c(4) = 1) Then
　　　res$ = "": 'LN4 何も表示しない定義
　 ElseIf (c(1) = 0) And (c(2) = "A") And (c(3) = 1) And (c(4) = 1) Then
　　　res$ = "": 'LN5 何も表示しない定義
　 ElseIf (c(1) = 0) And (c(2) = "B") And (c(3) = 1) And (c(4) = 1) Then
　　　res$ = "": 'LN6 何も表示しない定義
　 ElseIf (c(1) = 2) And (c(2) = "B") And (c(3) = 0) And (c(4) = 1) Then
　　　res$ = "": 'LN7 何も表示しない定義
　 ElseIf (c(1) = 1) And (c(2) = "B") And (c(3) = 0) And (c(4) = 1) Then
　　　res$ = "": 'LN8 何も表示しない定義
　 ElseIf (c(1) = 2) And (c(2) = "B") And (c(3) = 0) And (c(4) = 1) Then
　　　res$ = "": 'LN9 何も表示しない定義
　 ElseIf (c(1) = 0) And (c(2) = "B") And (c(3) = 1) And (c(4) = 1) Then
　　　res$ = "": 'LN10 何も表示しない定義
　 ElseIf (c(1) = 0) And (c(2) = "B") And (c(3) = 0) And (c(4) = 1) Then
　　　res$ = "": 'LN11 何も表示しない定義
　'ElseIf 条件12 Then
　'　 res$ = "": 'LN12 何も表示しない定義
　'ElseIf 条件13 Then
　'　 res$ = "": 'LN13 何も表示しない定義
　'ElseIf 条件14 Then
　'　 res$ = "": 'LN14 何も表示しない定義
　 '↓不具合
　 ElseIf (c(1) = 1) And (c(2) = "A") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L15 不具合"
　 ElseIf (c(1) = 2) And (c(2) = "A") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L16 不具合"
　 ElseIf (c(1) = 1) And (c(2) = "A") And (c(3) = 0) And (c(4) = 0) Then
　　　res$ = "L17 不具合"
　 ElseIf (c(1) = 2) And (c(2) = "A") And (c(3) = 0) And (c(4) = 0) Then
　　　res$ = "L18 不具合"
　 ElseIf (c(1) = 0) And (c(2) = "A") And (c(3) = 0) And (c(4) = 0) Then
　　　res$ = "L19 不具合"
　 ElseIf (c(1) = 0) And (c(2) = "A") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L20 不具合"
　 ElseIf (c(1) = 0) And (c(2) = "A") And (c(3) = 0) And (c(4) = 0) Then
　　　res$ = "L21 不具合"
　'ElseIf 条件22 Then
　'　 res$ = "L22 不具合"
　 ElseIf c(2) = "A" Then
　　　res$ = "L23 不具合"
　 ElseIf (c(1) = 1) And (c(2) = "B") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L24 不具合"
　 ElseIf (c(1) = 2) And (c(2) = "B") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L25 不具合"
　 ElseIf (c(1) = 1) And (c(2) = "B") And (c(3) = 0) And (c(4) = 0) Then
　　　res$ = "L26 不具合"
　 ElseIf (c(1) = 2) And (c(2) = "B") And (c(3) = 0) And (c(4) = 0) Then
　　　res$ = "L27 不具合"
　 ElseIf (c(1) = 0) And (c(2) = "B") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L28 不具合"
　 ElseIf (c(1) = 0) And (c(2) = "B") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L29 不具合"
　 ElseIf (c(1) = 1) And (c(2) = "C") And (c(4) = 0) Then
　　　res$ = "L30 不具合"
　 ElseIf (c(1) = 2) And (c(2) = "C") And (c(4) = 0) Then
　　　res$ = "L31 不具合"
　 ElseIf (c(1) = 0) And (c(2) = "D") And (c(3) = 1) And (c(4) = 0) Then
　　　res$ = "L32 不具合"
　 ElseIf (c(1) = 1) And (c(2) = "D") Then
　　　res$ = "L33 不具合"
　 ElseIf (c(1) = 2) And (c(2) = "D") Then
　　　res$ = "L34 不具合"
　'ElseIf 条件35 Then
　'　 res$ = "L35 不具合"
　'ElseIf 条件36 Then
　'　 res$ = "L36 不具合"
　'ElseIf 条件37 Then
　'　 res$ = "L37 不具合"
　 End If
　 Erase c
　 '
　 CheckDat = res$
End Function

定義漏れの分岐がないですけどね。
この分岐でヒットしなかったものを定義漏れとするならば、分岐指定ミス　を　定義漏れ　に変更してください。


	【9843】Re:リストボックスで選択したファイルの内...

ブーちゃん - 03/12/18(木) 14:16 -


	引用なし

	パスワード

御久しぶりです。暫く、貴方のコードを試していなかったので・・・
このプログラムは、UserFormを設定し、その中にListBoxとCommandButton1を設定した
物です。機能に変化は有りませんが、Sheet1中に、ListBoxとCommandButton1を設定す
る様にするには、どうすれば良いでしょうか？
又、、上記の通りに実行すると、Private Sub Command Button1_Click()を指して、「Function又は，変数が必要です」と表示されてしまいますので、どうすれば良いでしょ
うか？


	【9870】Re:リストボックスで選択したファイルの内...

ブーちゃん - 03/12/19(金) 15:38 -


	引用なし

	パスワード

ここで、打ち切りたいと思います。りんさん、これまで有難うございました。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

12568 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free