[[20170327163123]] 『セルに色を付けたいです。』(アイコス買えた) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『セルに色を付けたいです。』(アイコス買えた)

 参考にさせてもらっています。

以下のようなことは可能なのでしょうか?

エクセル A1に Z1-1 と入力
     A2に B3-2 と入力
     ・・・・・
     A50に Q31-7・・・
 
     Aに入力するのは アルファベットと数字です。      

ディスクトップにフォルダを作成、名前を仮にフォルダ1とします。
その中に Z1-1 のdxfファイルを入れる。

同じ名前があるときにAのセルに色が付く(Aでなくてもいいです。)
この場合だとA1(B1等でも問題ありません)に色が付く

可能なものでしょうか?
ヨロシクお願いします。

< 使用 Excel:Excel2003、使用 OS:unknown >


 シートモジュールに

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    Dim c As Range
    Dim fPath As String

    Set r = Intersect(Target, Columns("A"))
    If r Is Nothing Then Exit Sub

    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\フォルダ1\"
    r.Interior.ColorIndex = xlNone

    For Each c In r
        If Dir(fPath & c.Value & ".txt") <> "" Then c.Interior.Color = vbRed
    Next

 End Sub

(β) 2017/03/27(月) 16:59


 もしかして 関数処理がご希望?

 その場合は、どこか別の場所に フォルダ内のファイル一覧をつくっておいて、
 セルの値が、そのリストにあるかないか、MATCHあたりで検索してあった場合に色をつける条件付書式になると思います。

 そのフォルダ内のファイル一覧を手入力するのは面倒ということであれば、それを取り出してシート上に展開する部分を
 マクロにしておいて、実行しておくという手もあります。

(β) 2017/03/27(月) 17:35


 返信ありがとうございます。

返信を書いている間にかぶりました。

VBEはよく分からないのでコピー貼付けをしたのですが

上手くいきませんでした。

やったこと

エクセルを開いて Alt + F11 で画面を開く

左画面の Microsoht Excrl下のSheet1をダブルクリックして画面を開く

返信のあった式をコピー貼付け

右上の × をクリックして画面を閉じる

です。

エクセルを一度閉じて開くと マクロを有効にしますか?とは聞かれます。

有効にしますをクリックしていますが、色がつきません。

よろしくお願いします。
(アイコス買えた) 2017/03/27(月) 17:39


 出切ればですが、別で一覧を作成したくないので
VBEでいきたいです。
(アイコス買えた) 2017/03/27(月) 17:47

txtではなく、dxfでは
(mm) 2017/03/27(月) 18:07

 返信ありがとうございます。

dxf にしたら希望通りになりました。

このくらいは自分で確認しないといけませんでした、すみません。

βさん mmさん ありがとうございます。
(アイコス買えた) 2017/03/27(月) 18:18


再び質問させてください。

上で問題ないと思っていたのですが

フォルダにデータがある場合は問題なかったのですが

エクセルに入力してからフォルダにデータを入れると

色が付きません。

その場で色が付かなくてもいいのですが、保存して開いた時には色が付いているとうれしいです。

フォルダに「A1-1」データが入った状態でエクセルに「A1-1」を入力すると色が付く

エクセルに「A1-1」を入力してから、フォルダに「A1-1」を保存する、色が付かない
エクセル保存して、再び開いても色が付いていない。

Aをコピー貼付けすればいい話なのですが、複数のシートでこれを使わせてもらっているので
なるべく手間を省きたいと思っています。

よろしくお願いします。

(アイコス買えた) 2017/03/29(水) 09:31


 >複数のシートでこれを使わせてもらっているので 

 それでは、現在書いてあるシートモジュールのコードをすべて消してください。

 で、あらためて ThisWorkbookモジュールに以下を貼り付け、保存して閉じたうえで、開きなおしてみてください。

 なお、★印のところは実際の対象シート名に変えてください。

 Private Sub Workbook_Open()
    Dim sh As Worksheet
    For Each sh In Worksheets
        If ToDo(sh) Then
            With sh.Range("A1", sh.Range("A" & Rows.Count).End(xlUp))
                .Value = .Value
            End With
        End If
    Next
 End Sub

 Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    Dim r As Range
    Dim c As Range
    Dim fPath As String
    If ToDo(sh) Then
        Set r = Intersect(Target, sh.Columns("A"))
        If r Is Nothing Then Exit Sub

        fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\フォルダ1\"
        r.Interior.ColorIndex = xlNone

        For Each c In r
            If Dir(fPath & c.Value & ".dxf") <> "" Then c.Interior.Color = vbRed
        Next
    End If
 End Sub

 Private Function ToDo(sh As Worksheet) As Boolean
    Select Case sh.Name
        Case "Sheet1", "Sheet2", "Sheet3"       '★対象シートをいくつでも列挙
            ToDo = True
    End Select
 End Function

(β) 2017/03/29(水) 09:56


βさん

分かりやすく早い返答ありがとうございます。

1回で思っていた通りの事が出来ました。

ありがとうございます。
(アイコス買えた) 2017/03/29(水) 11:12


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.