人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

下記の仕様のマクロを組んで頂けないでしょうか…?
A
1.フォルダ指定する。フォルダ内の全ブック、シートを探索してシートのL列?P列にNGかNTという文字を検索
2.HITした時、該当列とその列から右に+1?4列の値(NGがL列にあれば、L?P列、N列にあれば、N?R列)を別シートList.xls を同フォルダ内に作成して値を代入。値が空の列は空白。
NG、NT列の右+1列目の値は文字列+整数になっている。例:AA111この整数部分だけ代入。
3.List.xlsの1行目には、A列 "ブック名"、B列 "シート名"、C列"結果"、D列 "NG番号"、E列"その他"、F列 "概要"、G列 "備考" とタイトルを入れる。そこにA列にNG,NTがあったブック名、B列にNG,NTがあったシート名、C?G列にNGNT列+1?4の列の値を入れる。シート名に西暦日付を入れて欲しい。
再度マクロを実行時にList.xlsが存在する場合は上書きではなくシート1を新しく作って西暦日付を入れて欲しい

B
1.ブックA.xlsを検索し、最初のシートのE列の値が"完了"となっている行のA列の値(1?9999の整数)と、Aで作ったList.xlsの最初のシートのD列の値を比較し、同じ場合はList.xlsの該当する行を青色で塗りつぶす。

●質問者: omoro
●カテゴリ:コンピュータ
✍キーワード:ng NT xls タイトル フォルダ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●400ポイント

こんな感じでどうでしょうか。

動作は試していますが、意図した動作と違う場合はコメント欄をオープンしていただければ対応します。

A

Sub MacroA()
 Dim obj As Object
 Dim FSO As Object, File As Variant
 Dim wb As Workbook
 Dim wbList As Workbook
 Dim strList As String
 Dim ws As Worksheet
 Dim count As Long
 Dim res As Object
 Dim firstAddress As String
 
 Set obj = Application.FileDialog(msoFileDialogFolderPicker)
 If obj.Show = False Then Exit Sub
 
 strList = obj.SelectedItems(1) & "\List.xls"
 If Dir(strList) = "" Then
 Set wbList = Workbooks.Add
 Else
 Set wbList = Workbooks.Open(strList)
 End If
 
 With wbList.Worksheets.Add
 .Name = Format(Now, "Long Date")
 .Range("A1").Value = "ブック名"
 .Range("B1").Value = "シート名"
 .Range("C1").Value = "結果"
 .Range("D1").Value = "NG番号"
 .Range("E1").Value = "その他"
 .Range("F1").Value = "概要"
 .Range("G1").Value = "備考"
 End With
 
 count = 2
 
 Set FSO = CreateObject("Scripting.FileSystemObject")
 For Each File In FSO.getfolder(obj.SelectedItems(1)).Files
 If InStr(File.Type, "Excel") > 0 And File.Name <> "List.xls" Then
 Set wb = Workbooks.Open(File.Path)
 For Each ws In wb.Worksheets
 Set res = ws.Range("L:P").Find(what:="NG", LookIn:=xlValues, lookat:=xlWhole)
 If Not res Is Nothing Then
 firstAddress = res.Address
 Do
 With wbList.Worksheets(1)
 .Cells(count, "A").Value = wb.Name
 .Cells(count, "B").Value = ws.Name
 .Cells(count, "C").Value = res.Value
 .Cells(count, "D").Value = getNum(res.Offset(0, 1).Value)
 .Cells(count, "E").Value = res.Offset(0, 2).Value
 .Cells(count, "F").Value = res.Offset(0, 3).Value
 .Cells(count, "G").Value = res.Offset(0, 4).Value
 End With
 count = count + 1
 Set res = ws.Range("L:P").FindNext(res)
 Loop While Not res Is Nothing And res.Address <> firstAddress
 End If
 Set res = ws.Range("L:P").Find(what:="NT", LookIn:=xlValues, lookat:=xlWhole)
 If Not res Is Nothing Then
 firstAddress = res.Address
 Do
 With wbList.Worksheets(1)
 .Cells(count, "A").Value = wb.Name
 .Cells(count, "B").Value = ws.Name
 .Cells(count, "C").Value = res.Value
 .Cells(count, "D").Value = getNum(res.Offset(0, 1).Value)
 .Cells(count, "E").Value = res.Offset(0, 2).Value
 .Cells(count, "F").Value = res.Offset(0, 3).Value
 .Cells(count, "G").Value = res.Offset(0, 4).Value
 End With
 count = count + 1
 Set res = ws.Range("L:P").FindNext(res)
 Loop While Not res Is Nothing And res.Address <> firstAddress
 End If
 Next
 wb.Close
 End If
 Next
 
 Application.DisplayAlerts = False
 If Application.Version < 12 Then
 wbList.SaveAs strList, FileFormat:=xlExcel9795
 Else
 wbList.SaveAs strList, FileFormat:=56
 End If
 wbList.Close
 Application.DisplayAlerts = True
End Sub

Function getNum(str As String) As String
 Dim res As String
 Dim i As Long
 
 For i = Len(str) To 1 Step -1
 If Mid(str, i, 1) Like "[0-9]" Then
 res = Mid(str, i, 1) & res
 Else
 Exit For
 End If
 Next i
 getNum = res
End Function

B

ここではA.xlsとList.xlsが存在することが前提です。

Sub MacroB()
 Dim obj As Object
 Dim wbA As Workbook
 Dim wbList As Workbook
 Dim strA As String
 Dim strList As String
 Dim res As Object
 Dim i As Long
 Dim lastRow As Long
 
 Set obj = Application.FileDialog(msoFileDialogFolderPicker)
 If obj.Show = False Then Exit Sub
 
 strA = obj.SelectedItems(1) & "\A.xls"
 Set wbA = Workbooks.Open(strA)
 strList = obj.SelectedItems(1) & "\List.xls"
 Set wbList = Workbooks.Open(strList)
 
 Set res = wbA.Worksheets(1).Range("E:E").Find(what:="完了", LookIn:=xlValues, lookat:=xlWhole)
 If Not res Is Nothing Then
 lastRow = wbList.Worksheets(1).Cells(Rows.count, 1).End(xlUp).Row
 For i = 2 To lastRow
 If wbList.Worksheets(1).Cells(i, "D").Value = wbA.Worksheets(1).Cells(res.Row, 1).Value Then
 wbList.Worksheets(1).Range(Cells(i, "A"), Cells(i, "G")).Interior.ColorIndex = 23
 End If
 Next i
 End If
 
 wbA.Close
 
 Application.DisplayAlerts = False
 If Application.Version < 12 Then
 wbList.SaveAs strList, FileFormat:=xlExcel9795
 Else
 wbList.SaveAs strList, FileFormat:=56
 End If
 wbList.Close
 Application.DisplayAlerts = True
End Sub
◎質問者からの返答

作成して頂き誠にありがとうございます。

マクロAは問題なく動作しておりました。

マクロBですが、仕様が曖昧だったせいか動作が期待通りではありませんでした。

A.xlsのA列には1?9999の整数(ダブりません)が、E列には"完了"or"空白"or"その他の文字"が入っています。

A.xlsで完了となっているA列の番号と同じ番号のLIST.xlsのD列の番号とを全て青く塗りつぶす。

A.xlsの完了となっているA列の数字が、1、5、11、119だった場合、LIST.xlsのD列が1、5、11、119の行を青く塗りつぶす。

こんな仕様なんですが、うまく伝わりましたでしょうか?


2 ● Mook
●500ポイント ベストアンサー

マクロBの方は、List.xls と ブックA.xls の関係がよくわかりませんでしたが、

Aと同じく、指定したフォルダにあるという仮定で回答しました。

Option Explicit

Public fso As Object
Public regExp As Object

'---------------------------------------------------
Sub OmoroMacroA()
'---------------------------------------------------
'// フォルダの選択
 Dim selectFolder As String
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = False Then Exit Sub
 selectFolder = .SelectedItems(1)
 End With

'// 処理前に List.xls が開いているか確認
 Dim dstWB As Workbook
 On Error Resume Next
 Set dstWB = Workbooks("List.xls")
 On Error GoTo 0
 If Not dstWB Is Nothing Then
  '無条件で保存して閉じる
 dstWB.Save
 dstWB.Close
 End If
 
'// 出力先ブック・シートの作成
 Dim dstPath As String
 dstPath = selectFolder & "\List.xls"
 
 Set regExp = CreateObject("VBScript.RegExp")
 With regExp
 .Pattern = "\d+"
 .Global = True
 End With
 
 Dim wsName As String
 wsName = Application.Text(Date, "YYYYMMDD")
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 
 Dim dstWS As Worksheet
 If fso.fileExists(dstPath) = True Then
'// 出力先ブックがある場合
 Set dstWB = Workbooks.Open(dstPath)
 On Error Resume Next
 Set dstWS = dstWB.Worksheets(wsName)
 On Error GoTo 0
 
 If dstWS Is Nothing Then
  '// 出力先シートがある場合
 dstWB.Worksheets.Add before:=dstWB.Worksheets(1)
 Set dstWS = dstWB.Worksheets(1)
 dstWS.Name = wsName
 Else
  '// 出力先シートがない場合
 If MsgBox("すでに" & wsName & "シートが存在します。" _
 & vbNewLine & "再作成しますか?", vbYesNo) = vbNo Then
 Exit Sub
 End If
 dstWS.Cells.Clear
 End If
 Else
'// 出力先ブックがない場合
 Set dstWB = Workbooks.Add()
 dstWB.SaveAs dstPath
 Set dstWS = dstWB.Worksheets(1)
 dstWS.Name = wsName
 End If
 
'// シートの初期設定
 dstWS.Range("A1:G1") = Array("ブック名", "シート名", "結果", "NG番号", "その他", "概要", "備考")
 Dim dstRow As Long
 dstRow = 2

'// ファイルの内容をスキャン
 Dim srcFile As Object
 Dim srcWS As Worksheet
 Dim startRow As Long
 For Each srcFile In fso.GetFOlder(selectFolder).Files
 If fso.GetExtensionName(srcFile.Path) = "xls" _
 And srcFile.Name <> "List.xls" _
 And InStr(srcFile.Name, "~$") = 0 Then
 startRow = dstRow
 With Workbooks.Open(srcFile.Path)
 For Each srcWS In .Worksheets
 dstRow = getDataFromWS(srcWS, dstWS, "NG", dstRow)
 dstRow = getDataFromWS(srcWS, dstWS, "NT", dstRow)
 Next
 .Close
 End With
 If dstRow > startRow Then
 dstWS.Rows(startRow & ":" & dstRow).Sort Key1:=dstWS.Cells(startRow, "Z"), order1:=xlAscending
 End If
 End If
 Next
 dstWS.Columns("Z").Clear
End Sub

'---------------------------------------------------
Function getDataFromWS(srcWS As Worksheet, dstWS As Worksheet, searchWord As String, dstRow As Long)
'---------------------------------------------------
 getDataFromWS = dstRow
 
 Dim fRng As Range
 Set fRng = srcWS.Columns("L:P").Find(searchWord, lookat:=xlWhole)
 If fRng Is Nothing Then Exit Function
 
 Dim sRng As Range
 Set sRng = fRng
 Do
 dstWS.Cells(dstRow, "A").Value = Replace(srcWS.Parent.Name, ".xls", "")
 dstWS.Cells(dstRow, "B").Value = srcWS.Name
 dstWS.Cells(dstRow, "C").Resize(1, 5).Value = fRng.Resize(1, 5).Value
 dstWS.Cells(dstRow, "D").Value = regExp.Execute(dstWS.Cells(dstRow, "D").Value)(0)
 dstWS.Cells(dstRow, "Z").Value = fRng.Row
 dstRow = dstRow + 1
 Set fRng = srcWS.Columns("L:P").FindNext(fRng)
 Loop While fRng.AddressLocal <> sRng.AddressLocal
 getDataFromWS = dstRow
End Function
Option Explicit

Public fso As Object

'---------------------------------------------------
Sub OmoroMacroB()
'---------------------------------------------------
 Const searchWSName = "ブックA.xls"

'// フォルダの選択
 Dim selectFolder As String
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = False Then Exit Sub
 selectFolder = .SelectedItems(1)
 End With

'// 処理前に List.xls が開いているか確認
 Dim dstWB As Workbook
 On Error Resume Next
 Set dstWB = Workbooks("List.xls")
 On Error GoTo 0
 If Not dstWB Is Nothing Then
  '無条件で保存して閉じる
 dstWB.Save
 dstWB.Close
 End If
 
'// 出力先ブック・シートの作成
 Dim dstPath As String
 dstPath = selectFolder & "\List.xls"
 
 Set fso = CreateObject("Scripting.FileSystemObject")
 
 Dim dstWS As Worksheet
 If fso.fileExists(dstPath) = False Then
 MsgBox "指定したフォルダに List.xlsがありません。"
 Exit Sub
 End If

'// List.xls を開く
 Set dstWB = Workbooks.Open(dstPath)

'// ファイルの内容をスキャン
 Dim srcFile As Object
 Dim srcWS As Worksheet
 Dim startRow As Long
 For Each srcFile In fso.GetFOlder(selectFolder).Files
 If srcFile.Name = searchWSName Then
 With Workbooks.Open(srcFile.Path)
 MarkListFile dstWB.Worksheets(1), Workbooks.Open(srcFile.Path).Worksheets(1)
 Exit For
 .Close
 End With
 End If
 Next
End Sub

'---------------------------------------------------
Sub MarkListFile(dstWS As Worksheet, srcWS As Worksheet)
'---------------------------------------------------
 Dim lastRow As Long
 lastRow = srcWS.Range("E" & Rows.Count).End(xlUp).Row
 
 Dim r As Long
 Dim fRng As Range
 For r = 1 To lastRow
 If srcWS.Cells(r, "E").Value = "完了" Then
 Set fRng = dstWS.Columns("D").Find(srcWS.Cells(r, "A").Value, lookat:=xlWhole)
 If Not fRng Is Nothing Then
 dstWS.Rows(fRng.Row).Interior.ColorIndex = 41
 End If
 End If
 Next
End Sub

マクロBはD列の最初に見つかった番号を対象にしました。

複数同じ番号があった場合は、対応が必要です。


仕様の誤解がある場合はコメントにて対応しますので、コメントを有効にお願いします。

◎質問者からの返答

作成して頂き誠にありがとうございます。

SALINGERさん同様、マクロAは問題なく動作しておりました。

しかしマクロBが仕様が曖昧だったせいか動作が期待通りではありませんでした。

A.xlsのA列には1?9999の整数(ダブりません)が、E列には"完了"or"空白"or"その他の文字"が入っています。

A.xlsで完了となっているA列の番号と同じ番号のLIST.xlsのD列の番号とを全て青く塗りつぶす。

A.xlsの完了となっているA列の数字が、1、5、11、119だった場合、LIST.xlsのD列が1、5、11、119の行を青く塗りつぶす。

こんな仕様なんですが、うまく伝わりましたでしょうか?


3 ● Mook
●0ポイント

仕様の確認等はコメントで行いたいので、質問下部のコメントを有効にお願いいたします。


回答に頂いたコメント通りに実装したつもりですが、どのような点が問題でしょうか。

まず、ブックAはどのように開くことを想定していますか?

選択したフォルダの中の "ブックA.xls" を想定していますが、これが違う名前であれば、

 Const searchWSName = "ブックA.xls"

を変更してください。

あるいは、A.xls のA列と List.xls のD列に記載された数値に全角、半角、余分なスペースがある

等の差異はあるでしょうか。


直接ファイルを指定したいのであれば、比較したい二つのファイルを開いた状態で、下記を

実行でもよいです(A.xls は適宜変更)。

'---------------------------------------------------
Sub OmoroMacroB2()
'---------------------------------------------------
 MarkListFile Workbooks("List.xls").Worksheets(1), Workbooks("A.xls").Worksheets(1)
End Sub

'---------------------------------------------------
Sub MarkListFile(dstWS As Worksheet, srcWS As Worksheet)
'---------------------------------------------------
 Dim lastRow As Long
 lastRow = srcWS.Range("E" & Rows.Count).End(xlUp).Row
 
 Dim r As Long
 Dim fRng As Range
 For r = 1 To lastRow
 If srcWS.Cells(r, "E").Value = "完了" Then
 Set fRng = dstWS.Columns("D").Find(srcWS.Cells(r, "A").Value, lookat:=xlWhole)
 If Not fRng Is Nothing Then
 dstWS.Rows(fRng.Row).Interior.ColorIndex = 41
 End If
 End If
 Next
End Sub

なお A は、処理内容は SALINGERさんの回答とほとんど同じ内容ですが、下記の点が動作上

異なっています。希望に近い方をご使用ください。

・List.xls に同日の日付シートがある場合、再作成するかの確認処理をいれている。

・List.xls に記入する順は各ファイルの行の小さい順にしている。


行情報を確認する場合は、Z列に記載していますので下記を削除してください。

 dstWS.Columns("Z").Clear

前回の回答中、マクロAの下記のコメントが逆でしたので、修正してお読みください。

  '// 出力先シートがある場合
  '// 出力先シートがない場合

失礼しました。


不明な点はコメントで対応いたします。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ