Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
266 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【77117】コンボボックスから時刻指定でアプリを起...
質問  きよ  - 15/5/23(土) 1:37 -
引用なし
パスワード
   初めまして、
皆様、宜しくお願い致します。


UserForm1に、コンボボックスを３つ、コマンドボタン１つを配置し、

コンボボックスのオブジェクト名を、
cbo_hh　　　　　　　　’ 時を入れるため
cbo_mm　　　　　　　　’ 分を入れるため
cbo_ss　　　　　　　　’ 秒を入れるため

コマンドボタンのオブジェクト名は、
cmd_start　　　　’ 実行ボタン

としました。


下記のコードを記述して、それぞれのコンボボックスで「cbo_hh」「cbo_mm」「cbo_ss」
から「時」「分」「秒」を指定しても、指定時刻になってもFirefoxが起動しません。

どうやったら、指定時刻にFirefoxを起動させることができるのでしょうか？
解決策をご存じの方がいらっしゃいましたら、ご教示のほど宜しくお願い致します。


※コードは、
−−−−−−−−−−−−−−−−−−−−−−
' (General) (Declarations)
　　Dim hh As Long
　　Dim mm As Long
　　Dim ss As Long
　　Dim starttime As Date
−−−−−−−−−−−−−−−−−−−−−−　　
Private Sub UserForm_Initialize()
　　
　　　　For hh = 0 To 23
　　　　　　UserForm1.cbo_hh.AddItem hh
　　　　Next

　　　　For mm = 0 To 59
　　　　　　UserForm1.cbo_mm.AddItem mm
　　　　Next
　　　　
　　　　For ss = 0 To 59
　　　　　　UserForm1.cbo_ss.AddItem ss
　　　　Next

End Sub
−−−−−−−−−−−−−−−−−−−−−−
Private Sub cmd_start_Click()
　　
　　hh = cbo_hh.ListIndex
　　mm = cbo_mm.ListIndex
　　ss = cbo_ss.ListIndex
　　
　　starttime = TimeSerial(hh, mm, ss)
　　
　　Application.OnTime EarliestTime:=starttime, Procedure:="firefox"
　　
End Sub
−−−−−−−−−−−−−−−−−−−−−−
Sub firefox()

　　Dim brows As Long
　　brows = Shell("C:\Program Files (x86)\Mozilla Firefox\firefox.exe", vbNormalFocus)
　　If brows = 0 Then MsgBox "起動に失敗しました"

End Sub
−−−−−−−−−−−−−−−−−−−−−−
・ツリー全体表示
【77116】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/5/22(金) 19:47 -
引用なし
パスワード
   ▼あや さん：

多分わからないのは

If f Is Nothing Then

　　If IsArray(vntA) Then
　　　　ReDim Preserve vntA(1 To UBound(vntA) + 1)
　　　　ReDim Preserve vntB(1 To UBound(vntB) + 1)
　　Else
　　　　ReDim vntA(1 To 1)
　　　　ReDim vntB(1 To 1)
　　End If

　　vntA(UBound(vntA)) = c.Value
　　vntB(UBound(vntB)) = c.Offset(, 1).Value

End If

ここですね。

配列にアンマッチのセルの情報を格納していくのですが、何個あるかわからないので
最初は Dim vntA As Variant といったように、配列ではなく、Variant型の変数として定義します。

で、データを格納する際、最初は、vntAやvntBは配列ではないので
IsArray(vntA) これは、配列なのかどうかの判定ですが、それがFalse。
なので、Else で
　　　　ReDim vntA(1 To 1)
　　　　ReDim vntB(1 To 1)
こうして、それぞれ、要素が１つだけの配列をまず生成します。
一方、２つめ以降は、IsArray(vntA) が True なので
　　　　ReDim Preserve vntA(1 To UBound(vntA) + 1)
　　　　ReDim Preserve vntB(1 To UBound(vntB) + 1)

これは　配列に今まではいっているものはそのままにして（Preserve) 配列を
指定された大きさにかえなさいというコードです。
で、UBound(vntA) は、その時点での要素数です。それに 1　を加えた数、つまり
今から格納しようとする値がはいる要素を１つ追加します。

で、

　　vntA(UBound(vntA)) = c.Value
　　vntB(UBound(vntB)) = c.Offset(, 1).Value

この時点では UBound は追加分が加えられた最終要素番号になっていますので
そこに、c.Value(A列の値）や c.Offset(,1).Value(B列の値）を格納します。
・ツリー全体表示
【77115】Re:シート1とシート2の内容で一致するも...
質問  あや  - 15/5/22(金) 19:30 -
引用なし
パスワード
   ▼β さん：
上手くいきそうです・・・！

教えていただきたいのですが、下記のコードは具体的に何をしているか教えていただけないでしょうか。

>　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　　　　　Set f = r.Find(What:=c.Value, LookAt:=xlWhole)
>　　　　　　If f Is Nothing Then
>　　　　　　　　If IsArray(vntA) Then
>　　　　　　　　　　ReDim Preserve vntA(1 To UBound(vntA) + 1)
>　　　　　　　　　　ReDim Preserve vntB(1 To UBound(vntB) + 1)
>　　　　　　　　Else
>　　　　　　　　　　ReDim vntA(1 To 1)
>　　　　　　　　　　ReDim vntB(1 To 1)
>　　　　　　　　End If


>▼あや さん：
>
>それではサンプル第２弾として。
>マッチしなかったＡ列の値を配列の vntA に、B列の値を配列の vntB に格納しています。
>これを参考にがんばれますか？
>
>Sub Sample2()
>　　Dim r As Range
>　　Dim c As Range
>　　Dim f As Range
>　　Dim vntA As Variant
>　　Dim vntB As Variant
>　　
>　　With Sheets("Sheet1")
>　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　End With
>　
>　　 With Sheets("Sheet4")
>　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　　　　　Set f = r.Find(What:=c.Value, LookAt:=xlWhole)
>　　　　　　If f Is Nothing Then
>　　　　　　　　If IsArray(vntA) Then
>　　　　　　　　　　ReDim Preserve vntA(1 To UBound(vntA) + 1)
>　　　　　　　　　　ReDim Preserve vntB(1 To UBound(vntB) + 1)
>　　　　　　　　Else
>　　　　　　　　　　ReDim vntA(1 To 1)
>　　　　　　　　　　ReDim vntB(1 To 1)
>　　　　　　　　End If
>　　　　　　　　
>　　　　　　　　vntA(UBound(vntA)) = c.Value
>　　　　　　　　vntB(UBound(vntB)) = c.Offset(, 1).Value
>　　　　　　　　
>　　　　　　End If
>　　　　Next
>　　End With
>　　
>　　If IsArray(vntA) Then
>　　　　MsgBox "A列では以下のものがマッチしません" & vbLf & Join(vntA, vbLf)
>　　　　MsgBox "そのB列の値は以下です" & vbLf & Join(vntB, vbLf)
>　　Else
>　　　　MsgBox "すべてマッチしていますよ"
>　　End If
>　　
> End Sub
・ツリー全体表示
【77114】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/5/22(金) 17:57 -
引用なし
パスワード
   ▼あや さん：

それではサンプル第２弾として。
マッチしなかったＡ列の値を配列の vntA に、B列の値を配列の vntB に格納しています。
これを参考にがんばれますか？

Sub Sample2()
　　Dim r As Range
　　Dim c As Range
　　Dim f As Range
　　Dim vntA As Variant
　　Dim vntB As Variant
　　
　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With
　
　　 With Sheets("Sheet4")
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　Set f = r.Find(What:=c.Value, LookAt:=xlWhole)
　　　　　　If f Is Nothing Then
　　　　　　　　If IsArray(vntA) Then
　　　　　　　　　　ReDim Preserve vntA(1 To UBound(vntA) + 1)
　　　　　　　　　　ReDim Preserve vntB(1 To UBound(vntB) + 1)
　　　　　　　　Else
　　　　　　　　　　ReDim vntA(1 To 1)
　　　　　　　　　　ReDim vntB(1 To 1)
　　　　　　　　End If
　　　　　　　　
　　　　　　　　vntA(UBound(vntA)) = c.Value
　　　　　　　　vntB(UBound(vntB)) = c.Offset(, 1).Value
　　　　　　　　
　　　　　　End If
　　　　Next
　　End With
　　
　　If IsArray(vntA) Then
　　　　MsgBox "A列では以下のものがマッチしません" & vbLf & Join(vntA, vbLf)
　　　　MsgBox "そのB列の値は以下です" & vbLf & Join(vntB, vbLf)
　　Else
　　　　MsgBox "すべてマッチしていますよ"
　　End If
　　
End Sub
・ツリー全体表示
【77113】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/22(金) 17:44 -
引用なし
パスワード
   ▼imori さん：

自信度、60%ぐらいになったかも。
クラスモジュール（Class1)を挿入してください。

（標準モジュール）

Option Explicit

Type status
　　hold As Boolean
　　ng As Boolean
End Type

Sub test3()
　　Dim clsPool As Collection
　　Dim cls As Class1
　　Dim w As Variant
　　Dim c As Range
　　Dim lvl As Long
　　Dim maxLvl As Long
　　Dim x As Long
　　Dim st As status
　　Dim i As Long
　　Set clsPool = New Collection
　　
　　With Range("A2", Range("A" & Rows.Count).End(xlUp))
　　　　maxLvl = WorksheetFunction.Max(.Columns(1))
　　　　ReDim w(1 To maxLvl)
　　　　'階層構造の取り込み
　　　　For Each c In .Cells
　　　　　　lvl = c.Value
　　　　　　Set cls = New Class1
　　　　　　cls.init c.Offset(, 1).Value
　　　　　　clsPool.add cls
　　　　　　Set w(lvl) = cls
　　　　　　If lvl > 1 Then
　　　　　　　　Set cls = w(lvl - 1)　'親
　　　　　　　　cls.add c.Row
　　　　　　End If
　　　　Next
　　　　'判定
　　　　For i = .Rows.Count + 1 To 2 Step -1
　　　　　　Set c = Cells(i, "A")
　　　　　　x = i - 1
　　　　　　If IsEmpty(c.Offset(, 2)) Then
　　　　　　　　Set cls = clsPool(x)
　　　　　　　　st = cls.GetStatus
　　　　　　　　If st.ng Then
　　　　　　　　　　c.Offset(, 2).Value = "NG"
　　　　　　　　ElseIf st.hold Then
　　　　　　　　　　c.Offset(, 2) = "保留"
　　　　　　　　Else
　　　　　　　　　　c.Offset(, 2).Value = "OK"
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　
　　End With
　　
　　Erase w
　　Set cls = Nothing
　　Set clsPool = Nothing
　　
End Sub

（クラスモジュール Class1)

Option Explicit

Dim pool As Collection
Dim myIndex As String

Sub init(idx As String)
　　Set pool = New Collection
　　myIndex = idx
End Sub

Sub add(dRow As Long)
　　pool.add dRow
End Sub

Function GetStatus() As status
　　Dim i As Long
　　If pool.Count = 0 Then
　　　　GetStatus.hold = True
　　　　Exit Function
　　End If
　　For i = 1 To pool.Count
　　　　Select Case Cells(pool(i), "C")
　　　　　　Case "NG": GetStatus.ng = True
　　　　　　Case "保留": GetStatus.hold = True
　　　　End Select
　　　　If GetStatus.ng Then Exit For
　　Next
　　
End Function

Private Sub Class_Terminate()
　　Set pool = Nothing
End Sub
・ツリー全体表示
【77112】Re:シート1とシート2の内容で一致するも...
質問  あや  - 15/5/22(金) 15:35 -
引用なし
パスワード
   ▼β さん：
たとえばなのですが、Sheet1のA列に以下のように入力されていて、Sheet4のA列、B列に以下のように入力されていました

＊Shhet1
いちご
りんご
ぶどう
みかん
めろん

＊Sheet4
いちご　　赤
りんご　　赤
ぶどう　　紫
みかん　　オレンジ
めろん　　緑
もも　　　ピンク
ばなな　　黄

このときSheet1のなかに”もも”と”ばなな”がありません。
で、一致しなかったこの二つのB列の”ピンク”と”黄”というのを結果で表示したいです。

頭が固いもので、一致条件でつくっていたコードをどう変更すれば一致しなかったものを表示するようにできるかと・・・
今までのは一致したものをカウントし、結果表示させましたが、逆に一致しなかったものをカウントさせ、それを結果表示させる、という展開がうまくいきません・・・

>▼あや さん：
>
>よく考えますと、あやさんも言っている通り、今までのコードで検索を行っており
>その中で見つかった場合、見つからなかった場合の条件判定をしているのですから
>とくにわからないところはないのでは？　と思います。
>具体的に、どこがわからないのかな？
>
>以下は、あくまでサンプルです。
>新規ブックのSheet1のA列にA1から適当な文字列をいれ
>またSheet4のA列にA1から、これまた適当な文字列をいれて
>以下実行してみてください。
>Sheet4のB列に、見つかった、見つからない　の判定を記載します・
>
>基本、これ以上でもこれ以下でもないと思いますので
>これを参考に、対処できませんか？
>
>やはり壁があればSOSください。
>
>Sub Sample()
>　　Dim r As Range
>　　Dim c As Range
>　　Dim f As Range
>　　
>　　With Sheets("Sheet1")
>　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　End With
>　　
>　　With Sheets("Sheet4")
>　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
>　　　　　　Set f = r.Find(What:=c.Value, LookAt:=xlWhole)
>　　　　　　If f Is Nothing Then
>　　　　　　　　c.Offset(, 1).Value = "見つかりません"
>　　　　　　Else
>　　　　　　　　c.Offset(, 1).Value = "見つかりました"
>　　　　　　End If
>　　　　Next
>　　End With
>End Sub
>>▼β さん：
>>お久しぶりです。
>>下記の回答ありがとうございました。
>>お礼が遅くなり申し訳ありません。
>>
>>今回またで申し訳ありませんが、質問をさせてください。
>>以前作っていただいたコードは一致している文字列を探し、一致しているものがあればそのセルを赤くし、別sheetの一致した文字列の隣の列のセルを結果として表示する、というものでしたが、今回その一致条件を探す前に、無いものを探す、ということを行いたいです。
>>
>>例えばですが、Sheet4のA列にいろいろと文字列を入れておき、Sheet4のA列に入力している文字列が一致検索で探していたところと同じところに1つでも一致しないものがあれば、Shhet4のA列で一致しなかったものの隣のB列の結果を表示する、
>>というふうに処理がしたいのですが・・・
>>
>>一致しているものを探す、の逆で一致していないものを探す、なので一致しているものを探すコードを利用して、無いものを探すコードに変えられれば
>>・・・と思い試行錯誤しているのですが、〜がなければというコードをつくるのが上手くいきません・・・
>>
>>処理としては、Sheet4のA列に書いてある文字列がSheet2のA列に無いものがないか調べる
>>→全て一致していることを確認できたら：以前作成した一致するものをさがす処理をする
>>→もし一つでもないものが見つかれば：Sheet4の見つからなかったものの隣のB列に書いてあることを結果として表示する
>>
>>どうか教えていただけないでしょうか。
>>
>>>▼あや さん：
>>>
>>>こんにちは
>>>
>>>アップされたコードにはいくつか（たくさん？）問題があります。
>>>
>>>１．領域.Find で、その領域の中を捜すわけですが、Cells と指定すると
>>>　　シート全体の領域になりますから、Ａ列以外にあってもマッチします。
>>>２．で、After は、その領域内の検索開始セルですが、領域が Cellsなら
>>>　　ActivesCell は当然シート内ですからＯＫですが、領域をA列にすると
>>>　　もし、A列以外が選択されている状態ならエラーになります。
>>>　　指定するならＡ列内のセル（A1 とか）か、あるいは指定しない（こちらを推奨）
>>>　　指定がなければ指定領域の先頭のセルから　とみなしてくれますので。
>>>３．「大文字の」という条件ですよね。
>>>　　ところが、MatchCase:=False　。これは大文字／小文字を区別しないという意味です。
>>>　　MatchCase:=True とする必要があります。
>>>４．Findメソッドを実行すると、検索が成功（マッチ）した場合は、そのセルオブジェクトが
>>>　　返されますが、失敗（アンマッチ）した場合は「Nothing」になります。
>>>　　この「Nothing」になっているオブジェクトは、参照できません。
>>>　　参照しようとするとエラーになります。（参照できないので Select もできません）
>>>５．そのFIndメソッドの結果を受ける変数を　oRange　としていますが、この　oRange　は
>>>　　どこでも参照していません。かわりに　Set c = Selection　とした結果の c を参照。
>>>　　きっと　領域.Find(条件).Select として、その　Selectされたセル（Selection)を
>>>　　使おうとしたんだと思いますが、検索失敗のことを考えると、領域.Find(条件).Select　は
>>>　　使ってはいけない構文です。（だから使っていないんですよね）
>>>６．c という　セルオブジェクトのプロパティに ColorIndex というものはありません。
>>>　　あるのは、Interior （ほかにもたくさんありますが）
>>>　　で、ColorIndex は、Interior のプロパティです。
>>>　　ですから、c.Interior.ColorIndex です。c.ColorIndex だと、実行時にエラーになります。
>>>７．さらに、その ColorIndex ですが、これは 1〜56。（その他に塗りつぶしなしの xlNone もありますが）
>>>　　で、これで指定するなら、ColorIndex = 3 です。
>>>　　一方、vbRed はインデックスではなく「色番号」で、実態は 255 です。
>>>　　ColorIndex に 255 を与えると、実行時エラーになります。
>>>　　vbRed で指定するなら Color = vbRed になります。
>>>
>>>これらを加味してたとえば
>>>
>>>Private Sub AAA_Click()
>>>　　Dim c As Range
>>>
>>>　　Set c = Columns("A").Find(What:="*AAA*" _
>>>　　　　　　　　　　　　　, LookIn:=xlFormulas _
>>>　　　　　　　　　　　　　, LookAt:=xlWhole _
>>>　　　　　　　　　　　　　, SearchOrder:=xlByRows _
>>>　　　　　　　　　　　　　, SearchDirection:=xlNext _
>>>　　　　　　　　　　　　　, MatchCase:=True _
>>>　　　　　　　　　　　　　, MatchByte:=False _
>>>　　　　　　　　　　　　　, SearchFormat:=False)
>>>　
>>>　
>>>　 If c Is Nothing Then
>>>　　　　MsgBox "AAAはありませんでした"
>>>　 Else
>>>　　　　c.Interior.Color = vbRed
>>>　　　　MsgBox "AAAがありました"
>>>　 End If
>>>　
>>>End Sub
・ツリー全体表示
【77111】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/5/22(金) 14:41 -
引用なし
パスワード
   ▼あや さん：

よく考えますと、あやさんも言っている通り、今までのコードで検索を行っており
その中で見つかった場合、見つからなかった場合の条件判定をしているのですから
とくにわからないところはないのでは？　と思います。
具体的に、どこがわからないのかな？

以下は、あくまでサンプルです。
新規ブックのSheet1のA列にA1から適当な文字列をいれ
またSheet4のA列にA1から、これまた適当な文字列をいれて
以下実行してみてください。
Sheet4のB列に、見つかった、見つからない　の判定を記載します・

基本、これ以上でもこれ以下でもないと思いますので
これを参考に、対処できませんか？

やはり壁があればSOSください。

Sub Sample()
　　Dim r As Range
　　Dim c As Range
　　Dim f As Range
　　
　　With Sheets("Sheet1")
　　　　Set r = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　End With
　　
　　With Sheets("Sheet4")
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　Set f = r.Find(What:=c.Value, LookAt:=xlWhole)
　　　　　　If f Is Nothing Then
　　　　　　　　c.Offset(, 1).Value = "見つかりません"
　　　　　　Else
　　　　　　　　c.Offset(, 1).Value = "見つかりました"
　　　　　　End If
　　　　Next
　　End With
End Sub
>▼β さん：
>お久しぶりです。
>下記の回答ありがとうございました。
>お礼が遅くなり申し訳ありません。
>
>今回またで申し訳ありませんが、質問をさせてください。
>以前作っていただいたコードは一致している文字列を探し、一致しているものがあればそのセルを赤くし、別sheetの一致した文字列の隣の列のセルを結果として表示する、というものでしたが、今回その一致条件を探す前に、無いものを探す、ということを行いたいです。
>
>例えばですが、Sheet4のA列にいろいろと文字列を入れておき、Sheet4のA列に入力している文字列が一致検索で探していたところと同じところに1つでも一致しないものがあれば、Shhet4のA列で一致しなかったものの隣のB列の結果を表示する、
>というふうに処理がしたいのですが・・・
>
>一致しているものを探す、の逆で一致していないものを探す、なので一致しているものを探すコードを利用して、無いものを探すコードに変えられれば
>・・・と思い試行錯誤しているのですが、〜がなければというコードをつくるのが上手くいきません・・・
>
>処理としては、Sheet4のA列に書いてある文字列がSheet2のA列に無いものがないか調べる
>→全て一致していることを確認できたら：以前作成した一致するものをさがす処理をする
>→もし一つでもないものが見つかれば：Sheet4の見つからなかったものの隣のB列に書いてあることを結果として表示する
>
>どうか教えていただけないでしょうか。
>
>>▼あや さん：
>>
>>こんにちは
>>
>>アップされたコードにはいくつか（たくさん？）問題があります。
>>
>>１．領域.Find で、その領域の中を捜すわけですが、Cells と指定すると
>>　　シート全体の領域になりますから、Ａ列以外にあってもマッチします。
>>２．で、After は、その領域内の検索開始セルですが、領域が Cellsなら
>>　　ActivesCell は当然シート内ですからＯＫですが、領域をA列にすると
>>　　もし、A列以外が選択されている状態ならエラーになります。
>>　　指定するならＡ列内のセル（A1 とか）か、あるいは指定しない（こちらを推奨）
>>　　指定がなければ指定領域の先頭のセルから　とみなしてくれますので。
>>３．「大文字の」という条件ですよね。
>>　　ところが、MatchCase:=False　。これは大文字／小文字を区別しないという意味です。
>>　　MatchCase:=True とする必要があります。
>>４．Findメソッドを実行すると、検索が成功（マッチ）した場合は、そのセルオブジェクトが
>>　　返されますが、失敗（アンマッチ）した場合は「Nothing」になります。
>>　　この「Nothing」になっているオブジェクトは、参照できません。
>>　　参照しようとするとエラーになります。（参照できないので Select もできません）
>>５．そのFIndメソッドの結果を受ける変数を　oRange　としていますが、この　oRange　は
>>　　どこでも参照していません。かわりに　Set c = Selection　とした結果の c を参照。
>>　　きっと　領域.Find(条件).Select として、その　Selectされたセル（Selection)を
>>　　使おうとしたんだと思いますが、検索失敗のことを考えると、領域.Find(条件).Select　は
>>　　使ってはいけない構文です。（だから使っていないんですよね）
>>６．c という　セルオブジェクトのプロパティに ColorIndex というものはありません。
>>　　あるのは、Interior （ほかにもたくさんありますが）
>>　　で、ColorIndex は、Interior のプロパティです。
>>　　ですから、c.Interior.ColorIndex です。c.ColorIndex だと、実行時にエラーになります。
>>７．さらに、その ColorIndex ですが、これは 1〜56。（その他に塗りつぶしなしの xlNone もありますが）
>>　　で、これで指定するなら、ColorIndex = 3 です。
>>　　一方、vbRed はインデックスではなく「色番号」で、実態は 255 です。
>>　　ColorIndex に 255 を与えると、実行時エラーになります。
>>　　vbRed で指定するなら Color = vbRed になります。
>>
>>これらを加味してたとえば
>>
>>Private Sub AAA_Click()
>>　　Dim c As Range
>>
>>　　Set c = Columns("A").Find(What:="*AAA*" _
>>　　　　　　　　　　　　　, LookIn:=xlFormulas _
>>　　　　　　　　　　　　　, LookAt:=xlWhole _
>>　　　　　　　　　　　　　, SearchOrder:=xlByRows _
>>　　　　　　　　　　　　　, SearchDirection:=xlNext _
>>　　　　　　　　　　　　　, MatchCase:=True _
>>　　　　　　　　　　　　　, MatchByte:=False _
>>　　　　　　　　　　　　　, SearchFormat:=False)
>>　
>>　
>>　 If c Is Nothing Then
>>　　　　MsgBox "AAAはありませんでした"
>>　 Else
>>　　　　c.Interior.Color = vbRed
>>　　　　MsgBox "AAAがありました"
>>　 End If
>>　
>>End Sub
・ツリー全体表示
【77110】Re:シート1とシート2の内容で一致するも...
発言  β  - 15/5/22(金) 13:23 -
引用なし
パスワード
   ▼あや さん：

思い出すのに、少し時間くださいね。
・ツリー全体表示
【77109】Re:階層構造のステータスの設定に関して
回答  ウッシ  - 15/5/22(金) 12:03 -
引用なし
パスワード
   こんにちは

こういう事でしょうか？

Sub test()
　　Dim h　　　　　As Long
　　Dim i　　　　　As Long
　　Dim j　　　　　As Long
　　Dim k　　　　　As Long
　　Dim ステータス As String
　　Dim mSh　　　　As Worksheet
　　Dim wSh　　　　As Worksheet
　　Dim r　　　　　As Range
　　Dim rr　　　　 As Range
　　
　　Set mSh = Worksheets("Sheet1")　'元データシート
　　Set wSh = Worksheets.Add
　　
　　With mSh
　　　　j = .Range("A" & Rows.Count).End(xlUp).Row
　　　　k = WorksheetFunction.Max(.Range("A2", .Range("A" & Rows.Count).End(xlUp)))
　　　　.Range("A1").Resize(j, 1).Copy wSh.Range("A1")
　　End With
　　
　　With wSh
　　　　For i = 2 To j
　　　　　　If .Cells(i, 1) > 1 Then
　　　　　　　　.Cells(i, 1).Resize(, .Cells(i, 1) - 1).Insert Shift:=xlToRight
　　　　　　End If
　　　　Next
　　　　mSh.Range("C1").Resize(j, 1).Copy wSh.Cells(1, k + 2)
　　　　On Error Resume Next
　　　　For h = k To 1 Step -1
　　　　　　For i = j To 2 Step -1
　　　　　　　　If .Cells(i, h) <> "" Then
　　　　　　　　　　If .Cells(i, k + 2) = "" Then
　　　　　　　　　　　　ステータス = ""
　　　　　　　　　　　　Set r = _
　　　　　　　　　　　　　　.Range(.Cells(i, h + 1), .Cells(j, h + 1)) _
　　　　　　　　　　　　　　.SpecialCells(xlCellTypeConstants)
　　　　　　　　　　　　If r Is Nothing Then
　　　　　　　　　　　　　　ステータス = "保留"
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　For Each rr In r
　　　　　　　　　　　　　　　　If rr.EntireRow.Cells(1, k + 2) = "NG" Then
　　　　　　　　　　　　　　　　　　ステータス = "NG"
　　　　　　　　　　　　　　　　ElseIf rr.EntireRow.Cells(1, k + 2) = "保留" Then
　　　　　　　　　　　　　　　　　　If ステータス <> "NG" Then
　　　　　　　　　　　　　　　　　　　　ステータス = "保留"
　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　ElseIf rr.EntireRow.Cells(1, k + 2) = "OK" Then
　　　　　　　　　　　　　　　　　　If ステータス = "" Then
　　　　　　　　　　　　　　　　　　　　ステータス = "OK"
　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　Next
　　　　　　　　　　　　End If
　　　　　　　　　　　　.Cells(i, k + 2) = ステータス
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　　　On Error GoTo 0
　　　　.Cells(1, k + 2).Resize(j).Copy mSh.Range("C1")
　　End With
　　Application.DisplayAlerts = False
　　wSh.Delete
　　Application.DisplayAlerts = True
　　
End Sub

一時シートに階層をビジュアル的に再セットしてから処理しています。
・ツリー全体表示
【77108】Re:階層構造のステータスの設定に関して
回答  imori  - 15/5/22(金) 10:33 -
引用なし
パスワード
   β さん、
おはようございます。imoriです。

色々と考えていただきありがとうございます。
事前定義の情報が少なくて申し訳ございませんでした。

>まず、階層は１〜４ですか？それとも、いくつあるかわからないのでしょうか？
→階層に関してはいくつあるか分からないですが、今のところ５が最大です。

>また、番号はユニークと考えていいですか？
→番号はユニークではありません。
　別の階層の下に同じ番号がつくケースもあります。

>それと、ステータス（Ｃ列？）は、あらかじめ何かがOKとかNGが記述されているのですか？
→階層の末端は基本的にはOK、保留、NGが記載されています。
　記載がない場合は、保留となります。

>それとも、全く空白で、マクロですべての（１〜４の）ステータスを記入するのですか？
>後者だとして、
>
>>4　　　　000008　　　　□(4)・・・下に階層が続かないためステータスは[保留]
>
>これがよくわかりません。階層5 がないのでわからないから保留？
>であれば、ここだけではなく、アップされたサンプルの階層４は、すべて保留じゃないですか？
→前者になります。

＞ステータスが記載されていないところ（空白）のみステータスを記入。
＞下の階層とは、下のすべての階層ではなく、「１つしたの階層のみ」
左様でございます。
階層１は階層２のステータスにより決定され、
階層２は階層３のステータスにより決定されます。
イメージは以下のようになります。

階層１　　　　　　　　階層２　　　　　　　　階層３　　　階層４　　　　
番号　　　　　　　　番号　　　　　　　　番号 　　　　　　番号　　　　
000001_____________000002__________000003_OK____________000004 OK
　　　　　　　　　　 |　　　　　　　　　　|_______________000005 OK
　　　　　　　　　　 |
　　　　　　　　　　 |_____________000006_____________000007 NG
　　　　　　　　　　 |　 　　　　　　　　|____________000008　　　　
　　　　　　　　　　 |　　　　　　　　　 |____________000009 NG
　　　　　　　　　　 |　　　　　　　　　 |____________000010 OK
　　　　　　　　　　 |
　　　　　　　　　　 |_____________000011_____________000012 OK
　　　　　　　　　　 |　　　　　　　　　　|___________000013 OK
　　　　　　　　　　 |
　　　　　　　　　　 |_____________000014 OK　　　　　　　　
　　　　　　　　　　　　　　　　　　　　　　　　　　　　
βさん、コード書いていただきありがとうございます。
これから書いていただいたコードを見てみます。
・ツリー全体表示
【77107】Re:シート1とシート2の内容で一致するも...
質問  あや  - 15/5/22(金) 9:38 -
引用なし
パスワード
   ▼β さん：
お久しぶりです。
下記の回答ありがとうございました。
お礼が遅くなり申し訳ありません。

今回またで申し訳ありませんが、質問をさせてください。
以前作っていただいたコードは一致している文字列を探し、一致しているものがあればそのセルを赤くし、別sheetの一致した文字列の隣の列のセルを結果として表示する、というものでしたが、今回その一致条件を探す前に、無いものを探す、ということを行いたいです。

例えばですが、Sheet4のA列にいろいろと文字列を入れておき、Sheet4のA列に入力している文字列が一致検索で探していたところと同じところに1つでも一致しないものがあれば、Shhet4のA列で一致しなかったものの隣のB列の結果を表示する、
というふうに処理がしたいのですが・・・

一致しているものを探す、の逆で一致していないものを探す、なので一致しているものを探すコードを利用して、無いものを探すコードに変えられれば
・・・と思い試行錯誤しているのですが、〜がなければというコードをつくるのが上手くいきません・・・

処理としては、Sheet4のA列に書いてある文字列がSheet2のA列に無いものがないか調べる
→全て一致していることを確認できたら：以前作成した一致するものをさがす処理をする
→もし一つでもないものが見つかれば：Sheet4の見つからなかったものの隣のB列に書いてあることを結果として表示する

どうか教えていただけないでしょうか。

>▼あや さん：
>
>こんにちは
>
>アップされたコードにはいくつか（たくさん？）問題があります。
>
>１．領域.Find で、その領域の中を捜すわけですが、Cells と指定すると
>　　シート全体の領域になりますから、Ａ列以外にあってもマッチします。
>２．で、After は、その領域内の検索開始セルですが、領域が Cellsなら
>　　ActivesCell は当然シート内ですからＯＫですが、領域をA列にすると
>　　もし、A列以外が選択されている状態ならエラーになります。
>　　指定するならＡ列内のセル（A1 とか）か、あるいは指定しない（こちらを推奨）
>　　指定がなければ指定領域の先頭のセルから　とみなしてくれますので。
>３．「大文字の」という条件ですよね。
>　　ところが、MatchCase:=False　。これは大文字／小文字を区別しないという意味です。
>　　MatchCase:=True とする必要があります。
>４．Findメソッドを実行すると、検索が成功（マッチ）した場合は、そのセルオブジェクトが
>　　返されますが、失敗（アンマッチ）した場合は「Nothing」になります。
>　　この「Nothing」になっているオブジェクトは、参照できません。
>　　参照しようとするとエラーになります。（参照できないので Select もできません）
>５．そのFIndメソッドの結果を受ける変数を　oRange　としていますが、この　oRange　は
>　　どこでも参照していません。かわりに　Set c = Selection　とした結果の c を参照。
>　　きっと　領域.Find(条件).Select として、その　Selectされたセル（Selection)を
>　　使おうとしたんだと思いますが、検索失敗のことを考えると、領域.Find(条件).Select　は
>　　使ってはいけない構文です。（だから使っていないんですよね）
>６．c という　セルオブジェクトのプロパティに ColorIndex というものはありません。
>　　あるのは、Interior （ほかにもたくさんありますが）
>　　で、ColorIndex は、Interior のプロパティです。
>　　ですから、c.Interior.ColorIndex です。c.ColorIndex だと、実行時にエラーになります。
>７．さらに、その ColorIndex ですが、これは 1〜56。（その他に塗りつぶしなしの xlNone もありますが）
>　　で、これで指定するなら、ColorIndex = 3 です。
>　　一方、vbRed はインデックスではなく「色番号」で、実態は 255 です。
>　　ColorIndex に 255 を与えると、実行時エラーになります。
>　　vbRed で指定するなら Color = vbRed になります。
>
>これらを加味してたとえば
>
>Private Sub AAA_Click()
>　　Dim c As Range
>
>　　Set c = Columns("A").Find(What:="*AAA*" _
>　　　　　　　　　　　　　, LookIn:=xlFormulas _
>　　　　　　　　　　　　　, LookAt:=xlWhole _
>　　　　　　　　　　　　　, SearchOrder:=xlByRows _
>　　　　　　　　　　　　　, SearchDirection:=xlNext _
>　　　　　　　　　　　　　, MatchCase:=True _
>　　　　　　　　　　　　　, MatchByte:=False _
>　　　　　　　　　　　　　, SearchFormat:=False)
>　
>　
>　 If c Is Nothing Then
>　　　　MsgBox "AAAはありませんでした"
>　 Else
>　　　　c.Interior.Color = vbRed
>　　　　MsgBox "AAAがありました"
>　 End If
>　
>End Sub
・ツリー全体表示
【77106】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/22(金) 8:38 -
引用なし
パスワード
   ▼imori さん：

↑で悩んだことを取り入れてみて・・・
でも、そもそも、要件の理解が間違っている公算大で、自信度10%ぐらいですが・・・

Sub Test2()
　　Dim i As Long
　　Dim w As Variant
　　Dim maxlvl As Long
　　Dim oldlvl As Long
　　Dim curlvl As Long
　　Dim myExists As Boolean
　　Dim myHold As Boolean
　　Dim myNG As Boolean
　　Dim x As Long
　　
　　maxlvl = WorksheetFunction.Max(Range("A2", Range("A" & Rows.Count).End(xlUp)))
　　oldlvl = maxlvl + 1
　　
　　ReDim w(1 To maxlvl, 1 To 3)
　　For x = 1 To maxlvl
　　　　w(x, exists) = False
　　　　w(x, hold) = False
　　　　w(x, ng) = False
　　Next
　　
　　For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
　　　　curlvl = Cells(i, "A").Value

　　　　If curlvl > oldlvl Then
　　　　　　For x = curlvl To maxlvl
　　　　　　　　w(x, exists) = False
　　　　　　　　w(x, hold) = False
　　　　　　　　w(x, ng) = False
　　　　　　Next
　　　　End If
　　　　
　　　　If IsEmpty(Cells(i, "C")) Then
　　　　　　myExists = False
　　　　　　myHold = False
　　　　　　myNG = False
　　　　　　If curlvl < maxlvl Then
　　　　　　　　For x = curlvl + 1 To maxlvl
　　　　　　　　　　If w(x, exists) Then myExists = True
　　　　　　　　　　If w(x, hold) Then myHold = True
　　　　　　　　　　If w(x, ng) Then myNG = True
　　　　　　　　Next
　　　　　　End If
　　　　　　If myNG Then
　　　　　　　　Cells(i, "C").Value = "NG"
　　　　　　ElseIf myHold Or Not myExists Then
　　　　　　　　Cells(i, "C").Value = "保留"
　　　　　　Else
　　　　　　　　Cells(i, "C").Value = "OK"
　　　　　　End If
　　　　End If
　　　　
　　　　w(curlvl, exists) = True
　　　　If Cells(i, "C").Value = "保留" Then w(curlvl, hold) = True
　　　　If Cells(i, "C").Value = "NG" Then w(curlvl, ng) = True
　　　　
　　　　oldlvl = curlvl
　　　　
　　Next
　　
End Sub
・ツリー全体表示
【77105】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/22(金) 6:55 -
引用なし
パスワード
   ▼imori さん：

おはようございます。

おはようございます

よ〜く考えると、アップしたコードは【欠陥コード】でした。

a 1
b 2
c 3
d 4
e 4
f 3
g 4
h 4
i 4
j 4
k 3
l 4
m 4
n 3

こんな階層があったとして、アップしたコードは階層1 ごとに各階層の状況をリセットしています。
逆にいえば、その間は、すべての階層における NG状況とか保留状況とか階層有無状況を保持。

でも、c の階層3に紐付く階層4は d,e のみですよね。コードでは、g〜j、i,m における状況も
保持されています。なので、d,eがOKでもm,nがNGなら c も（この c のステータスが空白なら） NG になります。

これを、当該階層に紐付く下の階層のみを参照するということは、手を入れれば可能ですが、悩ましいのは
仮に 階層2 の b 判定。ここがステータス空白だったとして、c,f,k,n の階層3を調べればいいのかもしれませんが
階層3の k に　手入力で OK が入っていたとして（そんなことはない？）階層4のlあるいはmがNGだったとすれば
本来は、階層2 の b も NG でしょうけど、k がOKなので、b もOKになってしまう？

そんなことはない、l,m がNGなら k には絶対に手入力で OK はいれないということなら
コードを（かなり）渇変えればできるような気もしますが。
・ツリー全体表示
【77104】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 22:50 -
引用なし
パスワード
   ▼imori さん：

要件をすっかり誤解しているかもしれませんが、とにかく書いてみました。

Sub Test()
　　Dim i As Long
　　Dim w As Variant
　　Dim maxlvl As Long
　　Dim oldlvl As Long
　　Dim curlvl As Long
　　Dim myExists As Boolean
　　Dim myHold As Boolean
　　Dim myNG As Boolean
　　Dim x As Long
　　
　　maxlvl = WorksheetFunction.Max(Range("A2", Range("A" & Rows.Count).End(xlUp)))
　　oldlvl = 1
　　　　
　　For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
　　　　If oldlvl = 1 Then
　　　　　　ReDim w(1 To maxlvl, 1 To 3)
　　　　　　For x = 1 To maxlvl
　　　　　　　　w(x, exists) = False
　　　　　　　　w(x, hold) = False
　　　　　　　　w(x, ng) = False
　　　　　　Next
　　　　End If
　　　　curlvl = Cells(i, "A").Value
　　　　
　　　　If IsEmpty(Cells(i, "C")) Then
　　　　　　myExists = False
　　　　　　myHold = False
　　　　　　myNG = False
　　　　　　If curlvl < maxlvl Then
　　　　　　　　For x = curlvl + 1 To maxlvl
　　　　　　　　　　If w(x, exists) Then myExists = True
　　　　　　　　　　If w(x, hold) Then myHold = True
　　　　　　　　　　If w(x, ng) Then myNG = True
　　　　　　　　Next
　　　　　　End If
　　　　　　If myNG Then
　　　　　　　　Cells(i, "C").Value = "NG"
　　　　　　ElseIf myHold Or Not myExists Then
　　　　　　　　Cells(i, "C").Value = "保留"
　　　　　　Else
　　　　　　　　Cells(i, "C").Value = "OK"
　　　　　　End If
　　　　End If
　　　　
　　　　w(curlvl, exists) = True
　　　　If Cells(i, "C").Value = "保留" Then w(curlvl, hold) = True
　　　　If Cells(i, "C").Value = "NG" Then w(curlvl, ng) = True
　　　　
　　　　oldlvl = curlvl
　　　　
　　Next
　　
End Sub
・ツリー全体表示
【77103】写真貼付マクロ
質問  いわっき  - 15/5/21(木) 19:39 -
引用なし
パスワード
   以前、ネットでダウンロードしたマクロを、アレンジして自分なりに作った写真帳があります。
エクセル2010では、リンクで貼り付けを行うため、困っています。
ネットで調べたところ、Pictures.Insertからshapes.Addpictureに換えれば、リンクではなく、エクセルに保存することが分かったのですが、マクロの組み換えが、まったくわかりません。
下記にマクロを貼り付けますので、どなたか組み換えをしていただけませんか？
宜しくお願いします。

Sub 写真貼付()
　　Dim myPath As String
　　Dim myImage As Variant
　　Cells(y1, x1).Select
　　
　　myPath = "C:"
　　ChDir myPath
　　myImage = Application.GetOpenFilename _
　　　　(filefilter:="JPEG形式(*.jpg;*.bmp), *.jpg;*.bmp", _
　　　　Title:="写真を選択してください")
　　If myImage <> False Then
　　　　ActiveSheet.Pictures.Insert(myImage).Select
　　　　Selection.Cut
　　　　Cells(ActiveCell.Row, ActiveCell.Column).Select
　　　　ActiveSheet.Paste

　　　　Selection.Width = Range(Cells(y1, x1), Cells(y2, x2)).Width
　　　　Selection.Height = Range(Cells(y1, x1), Cells(y2, x2)).Height
　　End If
　　Exit Sub

End Sub

Sub 写真貼付1()
　　y1 = 2: x1 = 8: y2 = 10: x2 = 22
　　写真貼付
End Sub

Sub 写真貼付2()
　　y1 = 2: x1 = 23: y2 = 10: x2 = 37
　　写真貼付
End Sub

Sub 写真貼付3()
　　y1 = 13: x1 = 8: y2 = 21: x2 = 22
　　写真貼付
End Sub

Sub 写真貼付4()
　　y1 = 13: x1 = 23: y2 = 21: x2 = 37
　　写真貼付
End Sub

Sub 写真貼付5()
　　y1 = 24: x1 = 8: y2 = 32: x2 = 22
　　写真貼付
End Sub
・ツリー全体表示
【77102】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 19:26 -
引用なし
パスワード
   ▼imori さん：

なんとなくわかったこと。

ステータスが記載されていないところ（空白）のみステータスを記入。
下の階層とは、下のすべての階層ではなく、「１つしたの階層のみ」

ということでしょうか？
・ツリー全体表示
【77101】Re:階層構造のステータスの設定に関して
発言  β  - 15/5/21(木) 18:58 -
引用なし
パスワード
   ▼imori さん：

コードは眺めた程度で、よく読んでいませんが確認です。

まず、階層は１〜４ですか？それとも、いくつあるかわからないのでしょうか？
また、番号はユニークと考えていいですか？
それと、ステータス（Ｃ列？）は、あらかじめ何かがOKとかNGが記述されているのですか？
それとも、全く空白で、マクロですべての（１〜４の）ステータスを記入するのですか？
後者だとして、

>4　　　　000008　　　　□(4)・・・下に階層が続かないためステータスは[保留]

これがよくわかりません。階層5 がないのでわからないから保留？
であれば、ここだけではなく、アップされたサンプルの階層４は、すべて保留じゃないですか？
・ツリー全体表示
【77100】階層構造のステータスの設定に関して
質問  imori  - 15/5/21(木) 15:50 -
引用なし
パスワード
   はじまして、imoriと申します。
現在以下のようなマクロを組んでいるのですが、
無限ループになってしまったり、分岐が上手くいかなかったりとで試行錯誤しており苦しんでおります。
どうかご教授ねがえませんでしょうか。

階層構造の末端部分のステータスによって、
一段階上のステータスが決まるマクロを書きたいです。
ステータスはOK、NG、保留があり、ステータス決定のルールは以下の通りです。
１．番号の下に階層が存在しない場合でステータスがブランクの場合は[保留]
２．番号の下に階層が存在しており、一つでもNGがあれば、上のステータスは[NG]
３．番号の下に階層が存在しており、NGがなく、一つでも保留があれば上のステータスは[保留]
４．番号の下に階層が存在しており、NG、保留がない場合は[OK]

以下のように並んでいる場合□の箇所のステータスを設定するマクロを作成したいです。
階層　　　　番号　　　　ステータス
1　　　　000001　　　　□(1)・・・2のステータスがNGのためNG
2　　　　000002　　　　□(2)・・・3のステータスにNGが存在するためNG
3　　　　000003　　　　OK
4　　　　000004　　　　OK
4　　　　000005　　　　OK
3　　　　000006　　　　□(3)・・・下の階層(4)にNGが存在するためNG
4　　　　000007　　　　NG
4　　　　000008　　　　□(4)・・・下に階層が続かないためステータスは[保留]
4　　　　000009　　　　OK
4　　　　000010　　　　NG
3　　　　000011　　　　□(5)・・・下の階層がOKのため[OK]
4　　　　000012　　　　OK
4　　　　000013　　　　OK
3　　　　000014　　　　OK


現在組んでいるマクロは以下の通りです。
以下の番号のステータスが一致しません。
000001
000002
他のやりかたを考えるべきと思い始めています。
ご教授願えますでしょうか。


Option Explicit

Sub Main()
Dim i, MaxRow As Long
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To MaxRow
　　階層設定 (i)
Next i
MsgBox "完了しました"

End Sub

Sub 階層設定(i)
Dim r, m, l As Long
Dim sArray() As String
m = 0
r = 0
Do While Range("C" & i).Value = ""

　　
　　'行の次の行の階層レベルが同じもしくは次の行が小さい場合、その行は末端のためステータス「保留」
　　If Range("A" & i).Value >= Range("A" & i + 1) Then
　　　　Range("C" & i) = "保留"
　　'行の次の行の階層が+１の場合は下に階層がある
　　Else
　　　　r = i + 1
　　　　'次の行のステータスがブランクではない場合
　　　　If Range("C" & r).Value <> "" Then
　　　　　　'次の行のレベルと次の次の行のレベルが同一である限り配列に値格納
　　　　　　Do
　　　　　　　　ReDim Preserve sArray(m)
　　　　　　　　sArray(m) = Range("C" & r).Value
　　　　　　　　r = r + 1
　　　　　　　　m = m + 1
　　　　　　Loop While Range("A" & r) = Range("A" & r + 1)
　　　　　　Range("C" & i) = ステータス設定(sArray())
　　　　　　'配列の解放
　　　　　　m = 0
　　　　　　Erase sArray
　　　　Else
　　　　　　'****上と同じ処理が続いてしまう。
　　　　　　If Range("A" & r).Value >= Range("A" & r + 1) Then
　　　　　　　　'行の次の行の階層レベルが同じもしくは次の行が小さい場合、その行は末端のためステータス「保留」
　　　　　　　　Range("C" & r) = "保留"
　　　　　　Else
　　　　　　　　階層設定 (i + 1)
　　　　　　　　
　　　　　　End If
　　　　End If
　　End If
Loop


End Sub

Function ステータス設定(sArray() As String) As String
Dim strResult, strTarget As String

strResult = Filter(sArray, "NG")
'NGが含まれている場合
If UBound(strResult) <> -1 Then
　　strTarget = "NG"
Else
　　'NGは含まれていないが、保留が含まれている場合
　　strResult = Filter(sArray, "保留")
　　If UBound(strResult) <> -1 Then
　　　　strTarget = "保留"
　　Else
　　　　strTarget = "OK"
　　End If
End If
ステータス設定 = strTarget
End Function


よろしくお願いします。
・ツリー全体表示
【77099】Re:設定済のテーブル内への転記
発言  doro  - 15/5/18(月) 16:42 -
引用なし
パスワード
   ▼kanabun さん：

本当に迅速に対応して頂きありがとうございます！
返信が遅くて申し訳ないです。。。
コードまでありがとうございます、大変見やすくなってますね。
With〜でこんなまとめ方もあるんですね、勉強になりました。

ただ、試してみた結果はDB(wst2)シートのA1:Q2がテーブル設定範囲
(1行目→項目行、2行目→明細はなし･テーブル自動拡張範囲)
なのですが、やはりテーブル外のA3から転記されます…

もう2行目には『test』みたいな行を作っておいて、
別ブックを作るときにもその行だけ残して使用するべきかなあとも考えてますが…
でも、もう少し解決策を求めて、こちらはこのままにさせて頂きます。

コード自体は大変見やすく分かりやすくなったので、頂きます！
ありがとうございました！！
・ツリー全体表示
【77098】Re:特定の文字間を抽出するマクロ
お礼  moko  - 15/5/17(日) 22:27 -
引用なし
パスワード
   γ 様

ありがとうございました。
私にとっては難易度がかなり高いようですが、頑張ってコードを作ってみます。
コード作成で添削いただくかもしれませんが、その際はご教授頂けますと幸いです。
文字列操作についてもっと勉強したいと思います。
ありがとうございました。

>> xlsで検索して一致したセルに対して順番に処理する、
>> というコードを入れていけばいいのでしょうか？
>そう思います。
># 文字列操作の関数は個数が少なく、それでいて結果が分かりやすいので、
># 労力以上の見返り（充実感）がある気がします。
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
266 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free