下記の仕様のマクロを組んで頂けないでしょうか…?

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の該当する行を青色で塗りつぶす。

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2011/02/11 17:18:08
  • 終了:2011/02/12 14:27:40

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/02/11 22:32:06

ポイント500pt

マクロ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列の最初に見つかった番号を対象にしました。

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


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

id:omoro

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

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の行を青く塗りつぶす。

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

2011/02/12 13:37:12

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3430ベストアンサー獲得回数9692011/02/11 20:57:50

ポイント400pt

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

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

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
id:omoro

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

マクロ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の行を青く塗りつぶす。

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

2011/02/12 13:36:23
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912011/02/11 22:32:06ここでベストアンサー

ポイント500pt

マクロ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列の最初に見つかった番号を対象にしました。

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


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

id:omoro

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

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の行を青く塗りつぶす。

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

2011/02/12 13:37:12
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912011/02/12 14:02:07

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


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

まず、ブック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の下記のコメントが逆でしたので、修正してお読みください。

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

失礼しました。


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

  • id:omoro
    MooK様

    度々申し訳ありません。
    ブック名の指定が間違っておりました。

    あと、
    >マクロBはD列の最初に見つかった番号を対象にしました。
    >複数同じ番号があった場合は、対応が必要です。

    こちら、同じ番号も色を塗って欲しいのですが対応可能でしょうか?

  • id:SALINGER
    早々に終了されたので、私の方のBの修正を上げておきます。
    >>
    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
    Dim firstAddress As String

    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)

    wbList.Worksheets(1).UsedRange.Interior.ColorIndex = xlNone

    Set res = wbA.Worksheets(1).Range("E:E").Find(what:="完了", LookIn:=xlValues, lookat:=xlWhole)
    If Not res Is Nothing Then
    firstAddress = res.Address
    lastRow = wbList.Worksheets(1).Cells(Rows.count, 1).End(xlUp).Row
    Do
    With wbList.Worksheets(1)
    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 With
    Set res = wbA.Worksheets(1).Range("E:E").FindNext(res)
    Loop While Not res Is Nothing And res.Address <> firstAddress
    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
    <<


    >SALINGERさんの回答とほとんど同じ内容ですが、下記の点が動作上異なっています。
    それ以外に、私の場合はブックを保存するときに2007環境でも動作するようにしていることですね。
  • id:Mook
    多くのポイント有難うございました。

    私の方は 2010 で作成していますが、拡張子を xls に指定している範囲では、
    どのバージョン(2000以降程度であれば)でも動作上の差異はないと思っていますが、
    どうでしょうか。ご使用のバージョン等、明記されるとよいかと思います。

    B の方を、私の回答で修正する場合は、下記のプロシージャの部分を置き換えてください。

    '---------------------------------------------------
    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 sRng As Range
      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
            Set sRng = fRng
            Do
              dstWS.Rows(fRng.Row).Interior.ColorIndex = 41
              Set fRng = dstWS.Columns("D").FindNext(fRng)
            Loop While sRng.AddressLocal <> fRng.AddressLocal
          End If
        End If
      Next
    End Sub
  • id:SALINGER
    Mookさんの場合はもともとList.xlsを保存するコードがありませんので。
    私の場合はコード中に開いたブックはちゃんとコード中で保存して閉じるようにしているので
    2007以降で動作させた場合、デフォルトの保存形式と違う拡張子で保存すると、
    開くときにエラーメッセージが出ることを防ぐコードを入れているという意味です。
    これはExcel2010でもExcel2007でも同じです。
     
    >List.xls に同日の日付シートがある場合、再作成するかの確認処理をいれている。
    質問文から1日一回実行することが容易に想像できましたので、あえてシート名のチェックはしていません。
    同様にコード中で過度のエラートラップをあえてしないのは、コードの可読性が損なわれることと
    Excelはそもそも使う環境により想定外の使い方がされるものなので全てを拾うことができないからです。
     
    私の方は自分の回答の優位?だけを提示して高評価を得ることにはあまり興味がありませんので、
    この辺にしておきます。Mookさんのコードを採用してあげてください。
  • id:Mook
    以降、本論に関係ないコメントは自粛します。
    失礼しました。
  • id:omoro
    SALINGERさん
    修正版のマクロありがとうございます。期待通りの動作
    を致しました。大変助かりました。
    両方ベストアンサーを複数選べれば良いのですが…。
    また、何かありましたら是非よろしくお願いします。
    ありがとうございました。

    Mookさん
    修正版試してみたのですが、処理が終わりませんでした。
    ブレークして確認してみました所、List.xlsの空白の行
    が青く塗りつぶされておりました。
    最初に頂いた、マクロの
    '---------------------------------------------------
    Sub MarkListFile(dstWS As Worksheet, srcWS As Worksheet)
    '---------------------------------------------------
    の部分(以下略)を差し替えたのですが、こちらの
    手順に問題ありますでしょうか。
  • id:Mook
    いえ、その手順で問題ないと思います。
    こちらでは動作いたしましたので、データに依存するものだと思いますが、コード中の
        If srcWS.Cells(r, "E").Value = "完了" Then
    の部分を
        If srcWS.Cells(r, "E").Value = "完了" And srcWS.Cells(r, "A").Value <> "" Then
    としてみても変わらないでしょうか。
  • id:omoro
    Mook様

    回答の通りにしたところ、期待どうりの動作となりました!
    何度も回答して頂きお手数おけしました。
    大変助かりました。
    ありがとうございます。
  • id:Mook
    無事動作してよかったですが、上記の内容で動作するようになったということは、
    完了 となっている行のA列が空白のものがあるということです。
    この場合、何も処理されないことになりますが、それは問題ないでしょうか。
  • id:omoro
    Mook様

    こちらで用意したサンプルシートが空白になっていたようです。
    A列が空白の場合はありませんので大丈夫です。

    ただ、本日別の環境で試した所、エラーコードが出てしまいました。
    エクセル2000なのですが、2000で動作するようには
    出来ませんでしょうか?

  • id:Mook
    具体的にエラーの出た位置と、エラーの内容、それからその時の変数(特にr等の行位置)、
    およびそれが示すセルの内容等はわかるでしょうか。
  • id:omoro
    Mook様

    お手数おかけいたします。

    マクロAの11行目
    「 With Application.FileDialog(msoFileDialogFolderPicker)」

    で、実行エラー438が表示されました。
    マクロBも同様の関数で、実行エラー438が表示されてしましました。

    以上よろしくお願い致します。
  • id:Mook
    2000 では FileDialog は使用できないようですね。

      With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        selectFolder = .SelectedItems(1)
      End With
    の部分を
      Dim objSelectedFolder As Object
      Set objSelectedFolder = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダ選択", 1)
      
      If objSelectedFolder Is Nothing Then
        Exit Sub
      Else
        selectFolder = objSelectedFolder.items.Item.Path
      End If
    に置き換えてみてください。
  • id:omoro
    Mookさん

    ありがとうございます。
    明日、早速実行してみます。
  • id:omoro
    MooKさん

    無事動きました。
    ありがとうございます。

    お手数でなければで結構なんですが、
    マクロ実行後に開いたブック(List.xls)、(ブックA.xls)
    を保存して自動で閉じたいのですが、どのように追記
    すればよいでしょうか?

    ※今までの回答で十分役立ちましたので、無視して
    頂いても問題ございません。
  • id:Mook
    処理が終わった後に結果を確認したいかと思い、開いた状態にしていたのですが、
    保存する場合は、
    Workbooks("ファイル名").Save
    閉じる場合は
    Workbooks("ファイル名").Close
    です。

    ですから、A の場合は、OmoroMacroA の最後(End Sub の前)に
      Workbooks("List.xls").Save
      Workbooks("List.xls").Close

    B の場合は、OmoroMacroA の最後に
      Workbooks("A.xls").Save
      Workbooks("A.xls").Close
      Workbooks("List.xls").Save
      Workbooks("List.xls").Close
    の追加になります。
  • id:Mook
    ただし、List.xls は dstWB という変数に代入していますので、
    上記の代わりに
       dstWB.Save
       dstWB.Close
    でも同じ動きになります。

    いろいろ説明しているサイトがありますが、
    http://www.asahi-net.or.jp/~ef2o-inue/menu/menu04.html
    など参考にされると、ご自身でもだんだん改良できる範囲ができるかと思います。
  • id:omoro
    マクロAの最後「dstWS.Columns("Z").Clear」
    の処理が走らないのかZ行に余分な文字があるのですが、
    いろいろやってみたのですが、良く分かりませんでした。。

  • id:omoro
    問題解決しました。
    お騒がせしました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません