Excel VBA質問箱 IV

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

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


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

263 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【77179】Re:ＩＥのリストボックスの選択

とし - 15/6/3(水) 12:22 -


	引用なし

	パスワード

ｆｏｒ　ｅａｃｈ分で探すのではなく、最初から指定する形でやってみたら
うまくいきました。

お騒がせして、申し訳ございません。

ご検討いただいた方々に、お礼申し上げます。

ありがとうございました。

・ツリー全体表示


	【77178】Re:一覧から参照

γ - 15/6/2(火) 20:53 -


	引用なし

	パスワード

▼☆Nonoka☆ さん：
>返信遅くなって申し訳ありません。
>関数ですとリストが増えるため、効率に限界があります。
限界があるとは、どのくらいの行数ですか？
実際に限界に達しているのですか？

ワークシートのイベント処理についてはこちらを参照。
ht　 tp://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_event.html

------------
書き方の一例です。
これをSheet1のシートモジュールにコピーペイストしてから、
K列に入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim v As Variant

　　If Target.Count > 1 Then Exit Sub　　 ' 複数領域が同時に変更されたら終了
　　　　　　　　　　　　　　　　　　　　　' 逆に、複数領域についても対象にしたいなら、
　　　　　　　　　　　　　　　　　　　　　' 繰り返し処理を行います。（応用編はそちらで）
　　If Target.Column <> 11 Then Exit Sub　' K列以外なら終了

　　v = Application.VLookup(Target.Value, Worksheets("Sheet2").Range("B:C"), 2, False)
　　If IsError(v) Then
　　　　MsgBox Target.Value & " は見つかりませんでした"
　　Else
　　　　Application.EnableEvents = False
　　　　Target.Offset(0, 1).Value = v
　　　　Application.EnableEvents = True
　　End If
　
End Sub

・ツリー全体表示


	【77177】Re:一覧から参照

☆Nonoka☆ - 15/6/2(火) 13:15 -


	引用なし

	パスワード

▼γ さん：
>こんにちは。
>changeイベントプロシージャを利用してもよいですが、
>VLOOKUPを使った計算式を利用するのではダメなんですか？
>比較的よく使われる関数だと思います。

γさん
返信ありがとうございます。
返信遅くなって申し訳ありません。
関数ですとリストが増えるため、効率に限界があります。
その為、困っています。

・ツリー全体表示


	【77176】Re:ＩＥのリストボックスの選択

とし - 15/6/2(火) 8:58 -


	引用なし

	パスワード

すみません。
少し補足させていただきます。

>リストボックスは４つあり、Ｎａｍｅは全て"sharyoId"です。
>for i=0 to 4
>for each a in document.getelementsbyname("sharyoId")(i)
>　　a.selectedindex = "2"
>next
>next i 　←追記
>という感じで、ｎａｍｅの後ろに（）で番号を付ければ、個別に選択できるかとおもいましたが、うまくいきません。
>（）無しだと、全てのリストボックスで２が選択できます。
↑
（）とは、２行目の（i）のことです。
３行目の"2"は、実際には関数が入ります。

ＩＥのプルダウン部分は
<html>
<body onkeydown="enterAction();" onload=top.valueClear();">
　<form name="○○" onsubmit="return submitCheck()" action="△△" method="post"
　 <table width="685">
　　<tbody>
　　 <tr>
　　　<td>
　　　 <select name="sharoId">　　　　　
　　　　文字列 - ~のテキストノード

となっており、最後の２行が４つ同じようにあります。
よろしく、お願いします。

・ツリー全体表示


	【77175】Re:シート1とシート2の内容で一致するも...

β - 15/6/1(月) 20:28 -


	引用なし

	パスワード

▼あやさん：

とりあえず（？）グループすべてがない場合にメッセージをだして終わるパターンです。

Sub Sample7_3()
　　Dim f As Range
　　Dim f2 As Range
　　Dim r As Range

　　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With

　　　Set f = r.Find(What:="れもん", LookAt:=xlWhole)
　　If f Is Nothing Then
　　　　MsgBox "黄色がない"
　　　　Exit Sub
　　End If

　　 Set f = r.Find(What:="いちご", LookAt:=xlWhole)
　　Set f2 = r.Find(What:="りんご", LookAt:=xlWhole)
　　If f Is Nothing And f2 Is Nothing Then
　　　　MsgBox "赤色がない"
　　　　Exit Sub
　　End If

　　　Set f = r.Find(What:="ぶどう", LookAt:=xlWhole)
　　If f Is Nothing Then
　　　　MsgBox "紫色がない"
　　　　Exit Sub
　　End If

End Sub

Sub Sample8_3()
　　Dim f As Range
　　Dim r As Range
　　Dim w As Variant
　　Dim v As Variant
　　Dim ans As String
　　Dim cnt As Long
　　
　　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With

　　 For Each w In Array(Array("れもん"), Array("いちご", "りんご"), Array("ぶどう"))
　　　　cnt = 0
　　　　For Each v In w
　　　　　　Set f = r.Find(What:=v, LookAt:=xlWhole)
　　　　　　If f Is Nothing Then
　
　　　　　　　　　ans = ""
　　
　　　　　　　　　Select Case v
　　　　　　　　　　Case "れもん"
　　　　　　　　　　　　ans = "黄色"
　　　　　　　　　　Case "いちご", "りんご"
　　　　　　　　　　　　ans = "赤色"
　　　　　　　　　　Case "ぶどう"
　　　　　　　　　　　　ans = "紫色"
　　　　　　　　End Select
　　　　　　　　cnt = cnt + 1
　　　　　　　　
　　　　　　End If
　　　　Next
　　　　
　　　　If cnt = UBound(w) + 1 Then
　　　　　　MsgBox ans & " がない"
　　　　　　Exit Sub
　　　　End If
　　　　
　　Next

End Sub

・ツリー全体表示


	【77174】Re:シート1とシート2の内容で一致するも...

β - 15/6/1(月) 17:11 -


	引用なし

	パスワード

▼あやさん：
>▼β さん：
>いただいたどちらのコードもいちごまたはりんご、片方だけある場合に”赤色がない”とでてきてしまいます・・・
>両方ともあれば出ませんでした・・・
>ごめんなさい、教えていただけないでしょうか

はい。そうしています。
つまり、　いちご　と　りんご　をグループとして、そのどれかがない場合は
それがないとみなしてメッセージだして終了。

いわゆる　ＯＲ　で判定。

そうではなく、いちご、りんごがグループの場合は、そのグループ内のすべてがない場合に
メッセージで終了というのが要件でしたか？

それなら、そういうように対応しますが？

・ツリー全体表示


	【77173】ＩＥのリストボックスの選択

とし - 15/6/1(月) 16:52 -


	引用なし

	パスワード

初心者です。
エクセルのデータを活用してＩＥの制御をしようとしています。
リストボックス（プルダウン？）が複数あり、それぞれ該当するリストを選択したいと思っています。

ただ、ＩＤが無く、Ｎａｍｅが全て同じなので、個別に選択することができずに悩んでいます。
リストボックスは４つあり、Ｎａｍｅは全て"sharyoId"です。
for i=0 to 4
for each a in document.getelementsbyname("sharyoId")(i)
　　a.selectedindex = "2"
next

という感じで、ｎａｍｅの後ろに（）で番号を付ければ、個別に選択できるかとおもいましたが、うまくいきません。
（）無しだと、全てのリストボックスで２が選択できます。

分かりにくい文章ですみませんが、よろしくお願いします。

・ツリー全体表示


	【77172】Re:シート1とシート2の内容で一致するも...

あや - 15/6/1(月) 16:37 -


	引用なし

	パスワード

▼β さん：
いただいたどちらのコードもいちごまたはりんご、片方だけある場合に”赤色がない”とでてきてしまいます・・・
両方ともあれば出ませんでした・・・
ごめんなさい、教えていただけないでしょうか

>▼あやさん：
>>できれば最初に引っかかったものだけメッセージとして出したいのですが・・・
>
>基本的に、何かを行った後処理を終了させるには Exit Sub を使えばよろしいかと。
>Exit Sub は、プロシジャ実行を終了させます。もし、この処理の後、この処理とは別の処理をするなら
>プロシジャを終了さセルに尾はまずいのですが、今回は、別の処理がないので。
>
>Sub Sample7_2()
>　　Dim f As Range
>　　Dim f2 As Range
>　　Dim r As Range
>　
>　　 With Sheets("Sheet1")
>　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　End With
>　
>　　 Set f = r.Find(What:="れもん", LookAt:=xlWhole)
>　　If f Is Nothing Then
>　　　　MsgBox "黄色がない"
>　　　　Exit Sub
>　　End If
>　
>　　Set f = r.Find(What:="いちご", LookAt:=xlWhole)
>　　Set f2 = r.Find(What:="りんご", LookAt:=xlWhole)
>　　If f Is Nothing Or f2 Is Nothing Then
>　　　　MsgBox "赤色がない"
>　　　　Exit Sub
>　　End If
>　
>　　 Set f = r.Find(What:="ぶどう", LookAt:=xlWhole)
>　　If f Is Nothing Then
>　　　　MsgBox "紫色がない"
>　　　　Exit Sub
>　　End If
>　
>End Sub
>
>Sub Sample8_2()
>　　Dim f As Range
>　　Dim r As Range
>　　Dim w As Variant
>　　Dim v As Variant
>　　Dim ans As String
>　
>　　 With Sheets("Sheet1")
>　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　End With
>
>　　 For Each w In Array(Array("れもん"), Array("いちご", "りんご"), Array("ぶどう"))
>　　　　For Each v In w
>　　　　　　Set f = r.Find(What:=v, LookAt:=xlWhole)
>　　　　　　If f Is Nothing Then
>　　　
>　　　　　　　　 ans = ""
>　　　　
>　　　　　　　　 Select Case v
>　　　　　　　　　　Case "れもん"
>　　　　　　　　　　　　ans = "黄色"
>　　　　　　　　　　Case "いちご", "りんご"
>　　　　　　　　　　　　ans = "赤色"
>　　　　　　　　　　Case "ぶどう"
>　　　　　　　　　　　　ans = "紫色"
>　　　　　　　　End Select
>　　　　
>　　　　　　　　 If ans <> "" Then
>　　　　　　　　　　MsgBox ans & " がない"
>　　　　　　　　　　Exit Sub
>　　　　　　　　End If
>　　　　　　End If
>　　　　Next
>　　Next
>　
>End Sub

・ツリー全体表示


	【77171】Re:シート1とシート2の内容で一致するも...

β - 15/6/1(月) 15:44 -


	引用なし

	パスワード

▼あやさん：
>できれば最初に引っかかったものだけメッセージとして出したいのですが・・・

基本的に、何かを行った後処理を終了させるには Exit Sub を使えばよろしいかと。
Exit Sub は、プロシジャ実行を終了させます。もし、この処理の後、この処理とは別の処理をするなら
プロシジャを終了さセルに尾はまずいのですが、今回は、別の処理がないので。

Sub Sample7_2()
　　Dim f As Range
　　Dim f2 As Range
　　Dim r As Range
　
　　 With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With
　
　　 Set f = r.Find(What:="れもん", LookAt:=xlWhole)
　　If f Is Nothing Then
　　　　MsgBox "黄色がない"
　　　　Exit Sub
　　End If
　
　　Set f = r.Find(What:="いちご", LookAt:=xlWhole)
　　Set f2 = r.Find(What:="りんご", LookAt:=xlWhole)
　　If f Is Nothing Or f2 Is Nothing Then
　　　　MsgBox "赤色がない"
　　　　Exit Sub
　　End If
　
　　 Set f = r.Find(What:="ぶどう", LookAt:=xlWhole)
　　If f Is Nothing Then
　　　　MsgBox "紫色がない"
　　　　Exit Sub
　　End If
　
End Sub

Sub Sample8_2()
　　Dim f As Range
　　Dim r As Range
　　Dim w As Variant
　　Dim v As Variant
　　Dim ans As String
　
　　 With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With

　　 For Each w In Array(Array("れもん"), Array("いちご", "りんご"), Array("ぶどう"))
　　　　For Each v In w
　　　　　　Set f = r.Find(What:=v, LookAt:=xlWhole)
　　　　　　If f Is Nothing Then
　　　
　　　　　　　　 ans = ""
　　　　
　　　　　　　　 Select Case v
　　　　　　　　　　Case "れもん"
　　　　　　　　　　　　ans = "黄色"
　　　　　　　　　　Case "いちご", "りんご"
　　　　　　　　　　　　ans = "赤色"
　　　　　　　　　　Case "ぶどう"
　　　　　　　　　　　　ans = "紫色"
　　　　　　　　End Select
　　　　
　　　　　　　　 If ans <> "" Then
　　　　　　　　　　MsgBox ans & " がない"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Next
　
End Sub

・ツリー全体表示


	【77170】Re:シート1とシート2の内容で一致するも...

あや - 15/6/1(月) 14:17 -


	引用なし

	パスワード

▼β さん：
どちらもわかりやすく、助かりました
できれば最初に引っかかったものだけメッセージとして出したいのですが・・・

れもんが無ければその続きのいちご、りんご、ぶどうはないので・・・
また、れもんはあり、次のいちごかりんご、どちらも無ければぶどうはないので・・・

>▼あやさん：
>
>ほんとに　↑　のようなコードでいいのかなぁ・・・？
>せめて
>
>Sub Sample8()
>　　Dim f As Range
>　　Dim r As Range
>　　Dim w As Variant
>　　Dim v As Variant
>　　Dim ans As String
>　　
>　　With Sheets("Sheet1")
>　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　End With
>　
>　　For Each w In Array(Array("れもん"), Array("いちご", "りんご"), Array("ぶどう"))
>　　　　For Each v In w
>　　　　　　Set f = r.Find(What:=v, LookAt:=xlWhole)
>　　　　　　If f Is Nothing Then
>　　　　　　
>　　　　　　　　ans = ""
>　　　　　　　　
>　　　　　　　　Select Case v
>　　　　　　　　　　Case "れもん"
>　　　　　　　　　　　　ans = "黄色"
>　　　　　　　　　　Case "いちご", "りんご"
>　　　　　　　　　　　　ans = "赤色"
>　　　　　　　　　　Case "ぶどう"
>　　　　　　　　　　　　ans = "紫色"
>　　　　　　　　End Select
>　　　　　　　　
>　　　　　　　　If ans <> "" Then
>　　　　　　　　　　MsgBox ans & " がない"
>　　　　　　　　　　Exit For
>　　　　　　　　End If
>　　　　　　End If
>　　　　Next
>　　Next
>　　
>End Sub

・ツリー全体表示


	【77169】Re:顧客管理の方法

田中 - 15/6/1(月) 11:48 -


	引用なし

	パスワード

上司から言われているフォームがあるので
それを崩してウッシ様が仰っているmdbテーブルで作成しても良いかどうか
判別が難しかったので、他の方の意見も欲しかったのですが
他の方からの案がどうやらありませんので、この形でも良いかどうか
上司と話し合ってから方向性考えてみます
ウッシ様有難う御座いました

・ツリー全体表示


	【77168】Re:シート1とシート2の内容で一致するも...

β - 15/5/30(土) 6:17 -


	引用なし

	パスワード

▼あやさん：

ほんとに　↑　のようなコードでいいのかなぁ・・・？
せめて

Sub Sample8()
　　Dim f As Range
　　Dim r As Range
　　Dim w As Variant
　　Dim v As Variant
　　Dim ans As String
　　
　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With
　
　　For Each w In Array(Array("れもん"), Array("いちご", "りんご"), Array("ぶどう"))
　　　　For Each v In w
　　　　　　Set f = r.Find(What:=v, LookAt:=xlWhole)
　　　　　　If f Is Nothing Then
　　　　　　
　　　　　　　　ans = ""
　　　　　　　　
　　　　　　　　Select Case v
　　　　　　　　　　Case "れもん"
　　　　　　　　　　　　ans = "黄色"
　　　　　　　　　　Case "いちご", "りんご"
　　　　　　　　　　　　ans = "赤色"
　　　　　　　　　　Case "ぶどう"
　　　　　　　　　　　　ans = "紫色"
　　　　　　　　End Select
　　　　　　　　
　　　　　　　　If ans <> "" Then
　　　　　　　　　　MsgBox ans & " がない"
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Next
　　
End Sub

・ツリー全体表示


	【77167】Re:シート1とシート2の内容で一致するも...

β - 15/5/29(金) 21:43 -


	引用なし

	パスワード

▼あやさん：

↑　ＯＲ　だったですかね？

そうであれば

　　If f Is Nothing And f2 Is Nothing Then

これを

　　If f Is Nothing Or f2 Is Nothing Then

・ツリー全体表示


	【77166】Re:シート1とシート2の内容で一致するも...

β - 15/5/29(金) 21:40 -


	引用なし

	パスワード

▼あやさん：

「以下のような感じ」をそのままコードにしました。

Sub Sample7()
　　Dim f As Range
　　Dim f2 As Range
　　Dim r As Range
　　
　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With
　　
　　Set f = r.Find(What:="れもん", LookAt:=xlWhole)
　　If f Is Nothing Then
　　　　MsgBox "黄色がない"
　　End If
　　
　　Set f = r.Find(What:="いちご", LookAt:=xlWhole)
　　Set f2 = r.Find(What:="りんご", LookAt:=xlWhole)
　　If f Is Nothing And f2 Is Nothing Then
　　　　MsgBox "赤色がない"
　　End If
　　
　　Set f = r.Find(What:="ぶどう", LookAt:=xlWhole)
　　If f Is Nothing Then
　　　　MsgBox "紫色がない"
　　End If
　　
End Sub

・ツリー全体表示


	【77165】Re:シート1とシート2の内容で一致するも...

あや - 15/5/29(金) 19:16 -


	引用なし

	パスワード

▼β さん：
説明が悪くてごめんなさい！！
以下のような感じです。

＝＝＝＝＝＝＝＝＝
Sub Sumple6
Dim　＊＊＊(変数宣言)
・
・
・

If　”レモン”がない
MsgBox　”黄色です”

ElseIf　”いちご”or”りんご”がない
MsgBox　”赤です”

ElseIf　”ぶどう”がない
MsgBox　”紫です”

Else
以前教えていただいた一致条件のコード

EndIf
・
・
・
End Sub
＝＝＝＝＝＝＝
　
というような感じで、Sheet2のA列のものと一致するか、とかではなく、コードに探す対象も書いてしまったほうが私にとって理解しやすいのかなと・・・
ごめんなさい、宜しくお願いします。

>▼あやさん：
>
>だんだん込み入ってきましたね。
>要件誤解あれば指摘願います。
>
>Sub Sample5()
>　　Dim dic As Object
>　　Dim r As Range
>　　Dim c As Range
>　　Dim f As Range
>　　Dim k As Variant
>　　Dim fVnt(1 To 1) As String
>　　Dim w As Variant
>　　
>　　Set dic = CreateObject("Scripting.Dictionary")
>　　
>　　With Sheets("Sheet1")
>　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　End With
>　　
>　　With Sheets("Sheet2")
>　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　　　　　k = c.Offset(, 1).Value　　　　 'B列の値赤とか緑とか
>　　　　　　If Not dic.exists(k) Then　　　 'はじめてあらわれた色か？
>　　　　　　　　fVnt(1) = c.Value　　　　　 '要素１つだけの配列にみかん等を格納し
>　　　　　　　　dic(k) = fVnt　　　　　　　 'それを辞書に登録(見出しは色）
>　　　　　　Else
>　　　　　　　　w = dic(k)　　　　　　　　　'辞書に登録されている配列を取り出し
>　　　　　　　　ReDim Preserve w(1 To UBound(w) + 1)　　'要素数を１つ増やし
>　　　　　　　　w(UBound(w)) = c.Value　　　'追加された最終要素にみかん等を格納し
>　　　　　　　　dic(k) = w　　　　　　　　　'それを辞書に再登録（置換　見出しは色）
>　　　　　　End If
>　　　　Next
>　　End With
>　　
>　　For Each k In dic　 '辞書から色を取り出す
>　　　　For Each w In dic(k)　　'そのいろに紐付くみかん等を取り出す
>　　　　　　Set f = r.Find(What:=w, LookAt:=xlWhole)
>　　　　　　If f Is Nothing Then
>　　　　　　　　MsgBox "アンマッチは " & k & "(" & w & ")"
>　　　　　　　　Exit For
>　　　　　　End If
>　　　　Next
>　　Next
>　　　　
>End Sub

・ツリー全体表示


	【77164】Re:顧客管理の方法

田中 - 15/5/29(金) 11:31 -


	引用なし

	パスワード

▼ウッシさん：
>こんにちは
>
>顧客毎に別ブックを作るのはどうかと思います。
>
>excel vba mdb テーブル作成とかでWEB検索すると色々なサイトが
>見つかりますので、DBで管理する方法に挑戦されてはどうでしょうか？

有難う御座います
全く道も方向性も見つからなかった状態だったので
こういったものがあると提示して下さっただけでとても有難いです
検索してみてどういった事が出来るのか、などいろいろと勉強してみます

他の方もこういった方法もある、等ありましたらそちらを勉強してみようかと思ってますのでご教示お願いします

・ツリー全体表示


	【77163】Re:顧客管理の方法

ウッシ - 15/5/29(金) 11:12 -


	引用なし

	パスワード

こんにちは

顧客毎に別ブックを作るのはどうかと思います。

excel vba mdb テーブル作成とかでWEB検索すると色々なサイトが
見つかりますので、DBで管理する方法に挑戦されてはどうでしょうか？

・ツリー全体表示


	【77162】顧客管理の方法

田中 - 15/5/29(金) 10:48 -


	引用なし

	パスワード

初投稿になります
現在エクセルによって、顧客と会員メンバーの情報を管理する方法を探しているのですが、なかなかうまくいきません

会社の方からは経費はかけられないのでアクセスや専門的ソフトは出来るだけ購入したく無いと言われております。ですが私が素人なのでそういったことに詳しく無く、どのようにマクロや関数を組んだら良いか悩んでおります

現状私の力で出来たものが、商品のナンバーと数量と会員NO.を入力すると自動で伝票に金額と顧客情報が載り、その伝票のシートにあるボタンを押すと自動で別ブックの履歴に登録されるシステム程度でして、最終的にはその履歴を利用して各顧客を管理していきたいのです。

ですが、履歴と1人1人の顧客情報を乗せたものを同じブックに入れてしまうと将来的に重くなってしまう事は目に見えているので、これを上手く管理する方法は無いかと模索しております

顧客は現状100人くらい居り、出来れば顧客名ごとにブックを作り、そのブックに先ほどの履歴の内容を利用した顧客ごとの購入履歴と顧客情報をそれぞれ作りたいのですが、どうするのが一番良いでしょうか

ご教示宜しくお願いいたします

・ツリー全体表示


	【77161】Re:条件付き書式で色づけしたセルをカウ...

ゆか - 15/5/28(木) 20:49 -


	引用なし

	パスワード

独覚さん

ありがとうございました！
お蔭様で、目指していたカレンダーを作ることが出来ました！
本当にありがとうございます。
また今度何か困った際には、是非宜しくお願いいたします！
本当に有難うございました！

・ツリー全体表示


	【77160】Re:シート1とシート2の内容で一致するも...

β - 15/5/28(木) 20:31 -


	引用なし

	パスワード

▼あやさん：

だんだん込み入ってきましたね。
要件誤解あれば指摘願います。

Sub Sample5()
　　Dim dic As Object
　　Dim r As Range
　　Dim c As Range
　　Dim f As Range
　　Dim k As Variant
　　Dim fVnt(1 To 1) As String
　　Dim w As Variant
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With
　　
　　With Sheets("Sheet2")
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　k = c.Offset(, 1).Value　　　　 'B列の値赤とか緑とか
　　　　　　If Not dic.exists(k) Then　　　 'はじめてあらわれた色か？
　　　　　　　　fVnt(1) = c.Value　　　　　 '要素１つだけの配列にみかん等を格納し
　　　　　　　　dic(k) = fVnt　　　　　　　 'それを辞書に登録(見出しは色）
　　　　　　Else
　　　　　　　　w = dic(k)　　　　　　　　　'辞書に登録されている配列を取り出し
　　　　　　　　ReDim Preserve w(1 To UBound(w) + 1)　　'要素数を１つ増やし
　　　　　　　　w(UBound(w)) = c.Value　　　'追加された最終要素にみかん等を格納し
　　　　　　　　dic(k) = w　　　　　　　　　'それを辞書に再登録（置換　見出しは色）
　　　　　　End If
　　　　Next
　　End With
　　
　　For Each k In dic　 '辞書から色を取り出す
　　　　For Each w In dic(k)　　'そのいろに紐付くみかん等を取り出す
　　　　　　Set f = r.Find(What:=w, LookAt:=xlWhole)
　　　　　　If f Is Nothing Then
　　　　　　　　MsgBox "アンマッチは " & k & "(" & w & ")"
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　Next
　　　　
End Sub

・ツリー全体表示


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

263 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free