Results of 1 - 1 of about 48829 for A�����������������������... (0.010 sec.)
- [[20121216091746]]
- #score: 1420
- @digest: fa97b34dec6daa327bb3015875b764a5
- @id: 61030
- @mdate: 2012-12-29T05:38:34Z
- @size: 62430
- @type: text/plain
- #keywords: adjustrange (299100), 丸番 (159983), slv (97381), 桁チ (95950), 丸文 (90924), ブロ (76739), ヨコ (57877), 丸数 (32493), ロッ (27698), 号", (25450), 型式 (20749), 領域 (18500), タテ (17171), base (16298), areas (14092), の領 (10171), currentregion (8158), と) (6960), cells (6864), ック (6568), value (6165), 先頭 (5430), resize (5004), ク先 (4977), offset (4928), ーバ (4597), rows (4555), intersect (4543), 黄色 (4144), ubound (4091), 番号 (3917), address (3796)
- 『配列を変えて表示したい』（KJS）
Excel2003 WindowsXPです。 資料 (A5:S52) を (AW:BA列) に表示したいのですが *1 丸番号は @〜S が必要なものだけランダムに配置されています。 例) 1つのブロックは、丸番号から右に2つセル迄、下は番号の連続が終わるまで @ブロックは A7:C11 の範囲です。 最大20ブロック迄有 AW列 に表示したい。 *2 丸番号の右セルに方向指示が有り、ヨコの場合は 1, タテの場合は O を BA列 に表示したい。 *3 丸番号の下セルとその右セルに型式表記が有り それを AZ列 に表示したい。 例) AZ9 セルに A8&B8 を表示したい。 *4 丸番号の2つ下から下へは最大24迄の番号が有り、番号の右セルとその右セルにデーターが有り、それを AY列 に表示したい。 例) AY9 セルに B9&C9 を表示 データーが無い(空白)の場合には _ (アンダーバー)を表示 *5 丸番号の下のセルに NBT と表記されていればそのブロックは (AW:BA列) に表示しない。 例) Q12 セルに B が有るが、Q13セルが NBT なので (AW:BA列) に表示しない。 「例として下記が有ります」 A B C E F G I J K M N O Q R S AW AX AY AZ BA 5 A タテ 6 NAT -330 7 @ ヨコ 1 R 11 8 NAT -440 2 S 11 8 丸番号 番号 データー 型式 方向 9 1 1 O 3 T 12 9 @ 1 1O NAT-400 1 10 2 1 P 4 U 12 10 2 1P 11 3 1 Q 5 13 11 3 1Q 12 6 Z B ヨコ 12 A 1 R11 NAT-330 0 13 7 V 14 NBT -400 13 2 S11 14 8 W 14 1 X 15 14 3 T12 15 2 Y 16 15 4 U12 16 3 Z 17 16 5 13 17 17 6 Z 18 18 7 V14 19 19 8 W14 20 20 J 1 10A NAT-20 1 21 21 2 10B 22 22 3 10C 23 23 4 10D 24 24 5 111E 25 25 6 111F 26 26 7 112G 27 27 8 200H 28 28 9 200H 29 29 10 200H 30 30 11 _ 31 J ヨコ 31 12 _ 32 NAT -20 32 13 _ 33 1 10 A 33 14 301I 34 2 10 B 34 15 302J 35 3 10 C 35 16 303K 36 4 10 D 36 17 304L 37 5 111 E 37 18 305M 38 6 111 F 38 19 306N 39 7 112 G 39 20 _ 40 8 200 H 41 9 200 H 42 10 200 H 43 11 44 12 45 13 46 14 301 I 47 15 302 J 48 16 303 K 49 17 304 L 50 18 305 M 51 19 306 N 52 20 上記の様に表示したいのですが、宜しく御教授下さい。 ---- いくつか質問 1.ランダムにと言うことだから開始行や開始列、その行数は決まっていないということだね? あるいは、列はきまっている? 2.それらブロックが存在する場所は A列〜AV列のどこかにあるということでいいのかな? 3.最大50ブロックということだけど、ブロックの順番は、どのように決める? ○数字で決めるの? それとも? (ぶらっと) ---- 説明不足で申し訳有りません。 1・丸文字の有る列は A列、E列、I列、M列、Q列と決まっています。 行は決まっていません。 2・ブロックは、 A5〜S52 の範囲内です。 3・ブロック数は最大20です。又順番は丸番号の若い順でと思っています。 (KJS) 宜しくお願い致します。 ---- 要件を誤解しているかもしれないけど、とりあえず。 各ブロックの最初の列には空白セルは無いという前提。 Sub Sample() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Set sl = CreateObject("System.Collections.SortedList") Set r = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52").SpecialCells(xlCellTypeConstants) For Each a In r.Areas If z Is Nothing Then Set z = a.CurrentRegion Else Set z = Union(z, a.CurrentRegion) End If Next For Each a In z.Areas sl(a.Cells(1).Value) = a.Address x = x + a.Rows.Count - 2 Next ReDim v(1 To x, 1 To 5) x = 1 For i = 0 To sl.Count - 1 With Range(sl.getbyindex(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 1, 0) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value x = x + 1 Next End With Next Columns("AW:BA").ClearContents Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub (ぶらっと) ---- お世話に成ります。 標準モジュールに Sub Sample()からEnd Sub迄を貼付しました。 マクロを実行すると 実行時エラー 429 「ActiveXコンポーネントはオブジェクトを作成できません」が表示されました。 Set sl = CreateObject("System.Collections.SortedList") の所が黄色になっています。 どうすれば良いですか。 (KJS) ---- 大変申し訳有りません 最初の条件が違っていました。 *2 丸番号の右セルに方向指示が有り、ヨコの場合は 1, タテの場合は O を BA列 に表示したい。 ↓ ↓ *2 丸番号の右セルに方向指示が有り、ヨコの場合は 0, タテの場合は 1 を BA列 に表示したい。 でした。 (KJS) ---- >Set sl = CreateObject("System.Collections.SortedList") の所が黄色になっています。 あぁ、XP だったね。ごめん。（XP でも .Net が搭載されていればOKだけど） タテとヨコのコードについては v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 1, 0) ここが【ヨコ】だったら 1、そうじゃなかったら 0 としているところ。 なので、 v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) こうすればいいんだけど、System.Collections.SortedListを使わないで処理するコード、 ちょっと時間くださいな。 (ぶらっと) ---- これで大丈夫だとおもうけど、とにかく試してみて。 Sub Sample2() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Dim slV(1 To 20) As String Set r = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52").SpecialCells(xlCellTypeConstants) For Each a In r.Areas If z Is Nothing Then Set z = a.CurrentRegion Else Set z = Union(z, a.CurrentRegion) End If Next For Each a In z.Areas Select Case a.Cells(1).Value Case "@" To "S" '念のため slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End Select Next ReDim v(1 To x, 1 To 5) x = 1 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value x = x + 1 Next End With End If Next Columns("AW:BA").ClearContents Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub (ぶらっと) ---- 試してみました。 質問が有ります。 1. @ブロックとAブロックが表示しません BとJブロックは表示します。 2. >*5 丸番号の下のセルに NBT と表記されていればそのブロックは (AW:BA列) に表示しない。 Bの下のセルが NBT と表記されているのに Bブロックが表示している。 3. >データーが無い(空白)の場合には _ (アンダーバー)を表示 例) F43:G45 にはデーターが無いので AY30:AY32 に アンダーバーを表示したい。 宜しくお願い致します。 (KJS) ---- > 1. @ブロックとAブロックが表示しません BとJブロックは表示します。 後述 > 2. >*5 丸番号の下のセルに NBT と表記されていればそのブロックは (AW:BA列) に表示しない。 Bの下のセルが NBT と表記されているのに Bブロックが表示している。 失念してた。ごめん。 > 3. >データーが無い(空白)の場合には _ (アンダーバー)を表示 例) F43:G45 にはデーターが無いので AY30:AY32 に アンダーバーを表示したい。 了解。 ということだけど、1.がわからないねぇ。こちらでは、@もAも表示されているので。 そちらのシート上の@やAが、コードでチェックしている@やAと合致しない? ブロック先頭のセルの丸文字の前や後にスペースなんかがあれば、それは、マッチしないけどね。 コードで認識していないものがあった場合メッセージを出すように仕掛けたので、どんなめっせーじがでるか（あるいはでないのか） 確認してくれる? Sub Sample3() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Dim slV(1 To 20) As String Set r = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52").SpecialCells(xlCellTypeConstants) For Each a In r.Areas If z Is Nothing Then Set z = a.CurrentRegion Else Set z = Union(z, a.CurrentRegion) End If Next For Each a In z.Areas Select Case a.Cells(1).Value Case "@" To "S" '念のため If a.Cells(2, 1).Value <> "NBT" Then slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End If Case Else MsgBox "ブロック先頭の丸文字が認識できません" & vbLf & a.Cells(1).Value End Select Next ReDim v(1 To x, 1 To 5) x = 1 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next End With End If Next Columns("AW:BA").ClearContents Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub (ぶらっと) ---- お世話になっています。 「ブロック先頭の丸文字が認識でこません」 の表示が出ました。 (KJS) ---- Aブロックを I5:K14 から I6:K15 へ移動したら @もAも表示しました。 (KJS) ---- >「ブロック先頭の丸文字が認識でこません」 の表示が出ました。 >Aブロックを I5:K14 から I6:K15 へ移動したら @もAも表示しました。 もう一度、Aブロックを元の場所に戻し、「ブロック先頭の丸文字が認識でこません」 のメッセージの下の行にでている その先頭文字が何であったか教えてくれる? このコードはシートの該当の列の【値が入力されている固まり】を抽出し、その固まりの左上に@やAが あるはずと思っているけど、たとえば、@の上にあるセルに、式が入っていて式の結果で "" となっているような場合 これがブロックの先頭と見なされ、その値が "" (長さ0の文字列）と見なされて対象外になる。 なにかしら、ブロックの回りに空白と見えて空白ではないセルが存在するとしか思えないけどね。 (ぶらっと) ---- ご苦労をお掛けしています。 >その先頭文字が何であったか教えてくれる? TB.デバイス と表示しています 尚そこは A1:K2 の結合セルです。 A1からT4 に結合セルが数個有ります。 Q1:S1 B3:C3 F3:G4 I3:I4 J3:K4 S3:T4 が結合セルです。 Aの上 I3:I4 の結合セルを解除すると表示出来ました。 この事が関係有りますか。 追記 上で書き方が間違っていました。 「ブロック先頭の丸文字が認識でこません」 →「ブロック先頭の丸文字が認識できません」 でした。 (KJS) ---- VBA処理で結合セルがある場合は、それなりのコードにする必要があるところが多々あるよ。 それと、アップしたコードはシート上には、このブロック以外は空白という前提だけど、そうじゃないんだね? さらに、ブロックの回りは空白行、空白列で囲まれているということが前提。 たとえばAのブロックの上は空白行だと思っている。そうじゃなく、そこには、何か、ブロックとは関係のないものが 記入されたセルがあるんだね?（結合であれ、通常のセルであれ） もしそうなら、ブロックがどこからどこまでかを判定することが、場合によっては無理になるよ。 まぁ、がらっと方法を変えて@〜Sの文字が記入されているセルを探し出し、そこがブロックの左上という 判定もできなくはないけど、それでも、ブロックの左右や下に、何か別の項目があれば、それもできなくなる。 一番確実なのは、ブロックの回りには値のあるセルがないということだけど、シートレイアウトを、そのようにできる? あるいは・・・ブロックは5行目以下ということでOKなら現在のコードを少しかえるだけですむけど。 (この場合、1〜4行目までには、結合セルがあろうが、値のあるブロック以外のセルがあろうがOK） 追記）↑ あぁ、そう書いてあったね。ブロックは5行目以下。 じゃぁ、なんとかできるな。 コードは明日になるのでしばしお待ち乞う。 (ぶらっと) ---- 説明のあったレイアウトを踏まえると、結合セル、単一セルということではなく、4行目に値が入っていないか 入っていたとしても、そのセル（結合セルあるいは単一セル）が5行目以降のブロックと【接触していなければ】 Sample3でOKだけど、実際にはそうではないようなので、以下。 (実はこれでも不十分なケースあり。5行目から始まるブロックが複数あり、4行目に値のあるセル（群）がその複数のブロックに ともに接触するようなケースは、一番左のブロックのみが抽出される。このような場合も想定するコードも書くことができるけど 面倒なので、できるだけ Saample3のままにしてある） Sub Sample4() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Dim slV(1 To 20) As String Dim base As Range Set base = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52") Set r = base.SpecialCells(xlCellTypeConstants) For Each a In r.Areas If z Is Nothing Then Set z = Intersect(base, a.CurrentRegion) Else Set z = Union(z, Intersect(base, a.CurrentRegion)) End If Next For Each a In z.Areas Select Case a.Cells(1).Value Case "@" To "S" '念のため If a.Cells(2, 1).Value <> "NBT" Then slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End If Case Else MsgBox "ブロック先頭の丸文字が認識できません" & vbLf & a.Cells(1).Value End Select Next ReDim v(1 To x, 1 To 5) x = 1 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next End With End If Next Columns("AW:BA").ClearContents Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub (ぶらっと) ---- (ぶらっと)さん 出来ました 有り難う御座います。 大変申し訳ありませんが AW1:BA7 に有るデーターを消えなくしたいのですがどうすれば良いですか このスペースに 職場の仲間が使える様に このマクロの使い方等を表記したいと思います (KJS) ---- じゃぁ、ちょっと手を抜いたコードだけど。 Dim w As Variant こんな宣言を追加しておいて Columns("AW:BA").ClearContents これを With Range("AW1:BA7") w = .Formula .EntireColumn.ClearContents .Value = w End With (ぶらっと) ---- (ぶらっと)さん 出来ました 大変有り難う御座います。 数ヶ月前からの課題が克服出来ました。 感謝 感謝です。 (KJS) ---- 再度の質問です。 丸番号の上部のセル 例) A6,A7,A8,I4,I5,I6 に文字が有った場合は マクロを実行すると 「ブロック先頭の丸文字が認識できません」 の表示が出て 数回 「OK」 を押すと AW:BA列に表示されますが 丸番号の上部セルにデーターが有るブロックは表示されません。 どうすれば良いですか。 (KJS) ---- ↓ 18:04 ロジック変更は無いけど、ちょっとだけコードをスリム化。 >どうすれば良いですか。 う〜ん・・・ 仕様上の【お約束】として、5行目から↓には【ブロックしかない】ということにしているので。 そのブロックの中で丸文字が存在するところの上の部分はブロックの対象ではないということなら以下。 ただし、たとえば、ブロックの下にも連続してブロックではない部分があったとき、それはブロックには含めない ということは不可能。 Sub Sample5() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Dim slV(1 To 20) As String Dim base As Range Set base = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52") Set r = base.SpecialCells(xlCellTypeConstants) For Each a In r.Areas Set a = adjustRange(Intersect(base, a.CurrentRegion)) If z Is Nothing Then Set z = a Else Set z = Union(z, a) End If Next For Each a In z.Areas Select Case a.Cells(1).Value Case "@" To "S" '念のため If a.Cells(2, 1).Value <> "NBT" Then slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End If Case Else MsgBox "ブロック先頭の丸文字が認識できません" & vbLf & a.Cells(1).Value End Select Next ReDim v(1 To x, 1 To 5) x = 1 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next End With End If Next Columns("AW:BA").ClearContents Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub Private Function adjustRange(a As Range) As Range Dim c As Range Dim x As Long For Each c In a.Columns(1).Cells Select Case c.Value Case "@" To "S" Exit For End Select x = x + 1 Next Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) End Function (ぶらっと) ---- (ぶらっと)さん 大変有り難う御座います。 約束違反の反則をやったようで 大変申し訳有りません。 Sample5 を使わせていただきます。 ブロックの下に1行以上のスペースが有れば見易いと思います。 わがままな注文に答えて頂きまして大変感謝致します。 (KJS) ---- >ブロックの下に1行以上のスペースが有れば見易いと思います。 AW:BA列のことかな? ReDim v(1 To x, 1 To 5) これを ReDim v(1 To x + r.Areas.Count, 1 To 5) で、最後の For/Nextのところに1行追加 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next End With x = x + 1 '★ 追加 End If Next これでOKだと思うよ。 (ぶらっと) ---- (ぶらっと)さん お世話に成りました。 最後の最後まで面倒を見ていただきまして大変有り難う御座います。 感謝でいっぱいです。 (KJS) ---- (ぶらっと)さん 使用して追加の質問が出来ました。 (AZ:BA列) の型式・方向によってデーターの最大桁数が決まっています。 (A5:S52)の資料を作る時点で桁数オーバーの場合には、パイプ（縦棒の様な記号）を使い 2行に印字する様にしていますが、資料作成ミス等に依る桁数オーバーの場合に AY列の該当セルに色を塗る等 目で見て解る様に表示出来ないでしょうか。（パイプが有ると2行に印字するソフトを使用している） わがまま言って大変申し訳有りません。 「型式に依る最大半角文字数」 型式 ヨコ タテ NKTU-15 5 5 NKTU-20 5 5 NKTU-30 7 5 NKT-60 6 3 NKT-130S 8 3 NKT-175S 8 3 NKT-240S 8 3 NKT-440S 8 3 NKT-660S 8 3 *下に参考例を表示します。 A B C E F G AW AX AY AZ BA 5 A タテ 6 NKT -175S 7 @ ヨコ 1 GGG 8 NKT U-20 2 HH I 丸番号 番号 データー 型式 方向 9 1 AAA BB 3 JJJ |KKK @ 1 AAABB NKTU-20 0 10 2 CCC DDD 4 LLL L|M 2 CCCDDD 11 3 EEEE |FFF 5 3 EEEE|FFF 12 4 4 _ 13 A 1 GGG NKT-175S 1 14 2 HHI 15 3 JJJ|KKK 16 4 LLLL|M 17 5 _ 型式 方向 最大文字数 データー文字数 AY9 NKTU-20 0(ヨコ) 5 5 可 AY10 NKTU-20 0(ヨコ) 5 6 不可 AY11 NKTU-20 0(ヨコ) 5 4+3 可 AY13 NKT-175S 1(タテ) 3 3 可 AY14 NKT-175S 1(タテ) 3 3 可 AY15 NKT-175S 1(タテ) 3 3+3 可 AY16 NKT-175S 1(タテ) 3 4+1 不可 以上になります。不可のセルを見て解る様に出来ませんか。 宜しくお願い致します。 追記 (ぶらっと)さん に最後に教えていただいた所 > >ブロックの下に1行以上のスペースが有れば見易いと思います。 > AW:BA列のことかな? すみません。実際使用してブロックの下の1行のスペースは無い方が良いと思いました。 (KJS) ---- この制限情報は、どこで規定しようか? どこかのシートにテーブルとして持たせてある? コードの中でテーブルを作り出してもいいけど、追加変更があった場合にコードを修正しなきゃいけないので マスターシートのようなものを作っておいた方がいいと思うけど。 >実際使用してブロックの下の1行のスペースは無い方が良いと思いました。 了解。 (ぶらっと) ---- とりあえず "マスタ" というシートを準備しよう。 1行目がタイトル（型式、ヨコ、タテ とか） 2行目から A列が型、B列が横の桁数、C列が縦の桁数 桁数は半角換算） アップ済みのコードの処理が終わった後のできあがりシートに対して単独に実行してもいいし 同時に行うなら、Sample5 の End Sub の直前に Call 桁チェック と、1行追加。 Sub 桁チェック() Dim dic As Object Dim c As Range Dim dkey As String Dim v As Variant Dim d As Variant Dim x As Long Set dic = CreateObject("Scripting.Dictionary") With Sheets("マスタ") For Each c In .Range("A1").CurrentRegion.Columns(1).Cells dic(c.Value & 0) = c.Offset(, 1).Value dic(c.Value & 1) = c.Offset(, 2).Value Next End With With Range("AY9", Range("AY" & Rows.Count).End(xlUp)) .Interior.ColorIndex = xlNone For Each c In .Cells '丸文字行ならキーを保存 If Len(c.Offset(, 2).Value) > 0 Then dkey = c.Offset(, 1).Value & c.Offset(, 2).Value If dic.exists(dkey) Then v = Split(c.Value, "|") For Each d In v '半角ベースで桁チェック x = LenB(StrConv(d, vbFromUnicode)) If x > dic(dkey) Then c.Interior.Color = vbRed '桁オーバー Exit For End If Next Else c.Interior.Color = vbYellow '登録無し End If Next End With End Sub (ぶらっと) ---- (ぶらっと)さん 出来ました。 桁数オーバーの場合はセルが赤に成りました。 登録の無い型式の場合はセルが黄色に成りました。 色が有るセルが表示された場合にはすぐに直せてミスを防げます。予想異常の仕様で出来ました。 追記 A5:S52 の範囲内で各ブロックの上下左右のセルのみが空白なら良いと思ってました。 上記 「*下に参考例を表示します」 の空白部 例) I〜S列に ブロックに関係のない文字が有ってもダメなんですね。 (KJS) ---- >A5:S52 の範囲内で各ブロックの上下左右のセルのみが空白なら良いと思ってました。 >例) I〜S列に ブロックに関係のない文字が有ってもダメなんですね。 領域内の値のあるセル領域の固まりについて、丸数字付きのブロックではない場合にメッセージを出しているところのこと? もともと、これは、ちゃんとしたブロックのつもりで、丸数字のセルが正しく入っていなかった場合の注意を促す目的。 なので、 MsgBox "ブロック先頭の丸文字が認識できません" & vbLf & a.Cells(1).Value この1行を消すか、先頭に ' をつけてコメントにすれば、メッセージはでなくなるよ。 処理には影響がないので、メッセージが不要ならどうぞ。 (ぶらっと) ---- 申し訳有りません。 私の説明が下手で正確に伝えられませんでした。 たとえば ブロックに全然関係の無い セルR20 に文字が有る場合 マクロを実行すると 「実行時エラー '10047'; アプリケーション定義またはオブジェクト定義のエラーです。」が表示され 「Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x)」の所が黄色に成る事でした。 (KJS) ---- あぁ、ごめん、ごめん。バグだった。 ブロックそのものであろうと、ブロック以外のものであろうと【そこが1行】のときの不具合。 さらに、今回の不具合で気がついたバグ有り。正常な（つもりの）ブロックが先頭の2行しかない場合も 別のところでエラーになる。 以下の対応をお願い。 For Each a In r.Areas Set a = adjustRange(Intersect(base, a.CurrentRegion)) If z Is Nothing Then Set z = a Else Set z = Union(z, a) End If Next これを For Each a In r.Areas If Intersect(base, a.CurrentRegion).Rows.Count < 3 Then MsgBox "ブロックが対象のものではないか、不充分です" & vbLf & a.Cells(1).Value Else Set a = adjustRange(Intersect(base, a.CurrentRegion)) If z Is Nothing Then Set z = a Else Set z = Union(z, a) End If End If Next このように変更。 (ぶらっと) ---- ブロックに全然関係の無いセルに文字が有る場合 そのセルの数や配置によって? 「ブロックが対象のものではないか、不充分です」 と表示する場合と 「実行時エラー '10047'; アプリケーション定義またはオブジェクト定義のエラーです。」が表示され 「Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x)」の所が黄色に成る事が有ります。 解決方法は有りますか。 (KJS) ---- プロシジャ adjustRange を以下のように入れ替えて。 Private Function adjustRange(a As Range) As Range Dim c As Range Dim x As Long For Each c In a.Columns(1).Cells Select Case c.Value Case "@" To "S" Exit For End Select x = x + 1 Next If a.Rows.Count = x Then Set adjustRange = a Else Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) End If End Function (ぶらっと) ---- 入れ替えしました。 ブロックに全然関係の無いセルに文字が不規則に有る場合 そのセルの数や配置によって 「ブロックが対象のものではないか、不充分です ****」 「ブロック先頭の丸文字が認識できません ****」 が数回表示されます。 メッセージを表示しない様にすると どの様な不都合が有りますか。 不都合が無ければ 先頭に ' をつけて表示しないようにした使用したいと思います。 (KJS) ---- >メッセージを表示しない様にすると どの様な不都合が有りますか。 うえのほうでもコメントしたけどロジック的にはメッセージを表示しなくても大丈夫。 たんに、正しいブロックのつもりで入力したけど、どこかがおかしくてAW:BA列に反映しないものがあった時に どこかがおかしかったんだなと、慌てずに入力を見直してもらえればそれでOK。 (ぶらっと) ---- (ぶらっと)さん 大変有難う御座います。 1週間以上教えて頂きまして感謝申し上げます。 最後に わがまま言って申し訳有りませんが マクロの解説をお願い出きれば幸いです。 (KJS) ---- >マクロの解説をお願い出きれば幸いです (KJS)さんのVBAレベルがどうかによって、コード解説より、ポイントとなる処理の説明にとどめた方が よりわかりやすいかもしれないと、ちょっと悩んだりしている。 一定のレベルにある人に対して、わかりきったコードを逐一解説するのも、かえって読みづらくなるだろうし。 まず、いくつか、この処理で使っている機能について。（必要なら、コードの解説もアップするよ） ・規定領域内のブロックの取得 Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52") この中で、連続して値があるところを抽出している。これが、Set r = base.SpecialCells(xlCellTypeConstants) ただ、この処理で、やりにくいところは1つ。結果は、連続した矩形の領域になるんだけど、たとえば この領域に @ ヨコ NAT -440 1 1 0 2 1 P 3 1 Q こんなものがあったとする。で、領域として @ から Q までの 5行3列の取得ができればいいんだけど 実際には、@〜-440 までの2行2列 と 1〜Q までの3行3列 の2つの領域にわかれてしまう。 なので、それぞれの領域.Creentregion の領域を取得。（これで、希望の 5行3列 の領域になる） 2つの領域がそれぞれ、同じ CreentRegion を持つけど、同じものを Union で結合させれば、上書き（じゃないけど）のような感じで 1つだけになる。 新規ブックのシートの任意の場所に上記データを書き込み、この 5行3列 をマウスで選択して以下を実行するとわかってもらえるんじゃないかな? Sub Test() Dim r As Range Dim a As Range Set r = Selection.SpecialCells(xlCellTypeConstants) MsgBox r.Address MsgBox r.Areas(1).CurrentRegion.Address & vbLf & r.Areas(2).CurrentRegion.Address Set a = Union(r.Areas(1).CurrentRegion, r.Areas(2).CurrentRegion) MsgBox a.Address End Sub ・ブロック補正 取得したブロック（と、思われる固まり）の先頭が必ずしも、丸数字から始まるブロックではなく ブロックの上に、何行かブロック以外のものがあるということなので、たとえば ああああ いいいい @ ヨコ NAT -440 1 1 0 2 1 P 3 1 Q こんな固まりがあったとき、丸数字が現れるまでの部分をカットして、あくまで丸数字から最後までの領域に変換するのが サブルーティンの AdjustRange。 なお、ここに丸数字がなかった場合は領域変換はしないで、そのままの領域として扱う。 ・丸数字の並び替え 当初はSortedList を提示したけど XP なので使えず、苦肉の策で 20個の要素を持つ1次元配列を用意。(slV) 1番目が @、20番目がS （要素番号は @〜S に対する文字コード から算出） ここにブロックの領域アドレスを格納して、最後に、この配列の上から順に領域を参照して、転記用配列（v)に上からセット。 slVからの取り出しが終了したら、v からセルに一挙に転記。 ・桁チェック マスタシートから 型0 型1 について それぞれの半角文字制限数をDictionaryに登録。 AY9から始まる転記領域のそれぞれの記載内容を | で分解して、分解された、それぞれの文字列の桁数と Dictionaryに登録された文字数とを淡々と比較し、桁オーバなら色塗り。 (ぶらっと) ---- (ぶらっと)さん 大変有難う御座います。 コードの解説をお願い致します。 高年齢でVBA超初級の私ですが、コードの解説をやっていただき勉強したいと思います。 (KJS) ---- コード解説の前に、↑でいいわすれたこと。 2つの領域に分かれたものを、その領域.CurrentRegion にして、連続しているそれらを a.CurrentRegion で1つの領域にしていると 説明したけど、さらに、それを、そのまま使わず、Intersect(base, a.CurrentRegion) というもので加工している。 Intersect は、指定領域が重なったところという意味だけど、a.CurrentRegion は、連続した上下のみならず、左右に連続した値があるセルも 取り込んでしまう。なので、その左右にくっついた領域があったとしても、base という ブロックが存在可能領域と Intersect することで、 左右の余分な領域（体脂肪のようなもの?）をそぎ落としている。 さて、コード。ポイントかなと思われるところのみコードの下に●印で説明。 Dim v() As Variant ●配列を宣言。ただし大きさについては、ここでは未確定という () 宣言。 こういった配列を「動的配列」と呼び、大きさが決まった時点で Redim で規定を行う。 Dim slV(1 To 20) As String ●@からSのブロックの領域情報を格納する配列。 ちなみに、@は、コードで言えば -30912。これは ASC("@") で取得可能。 また、Sは -30893。 @からSのコードは、1ずつ増えていく。 なので、ASC(丸文字)-ASC("@")+1 のコードで、@が 1、Sが 20 という番号が取得できる。 Set base = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52") ● Range("○○○,△△△,□□□,・・・・,◎◎◎") このように ( ) の中の先頭と最後のみに " がある場合 ○○○と△△△と□□□と・・・・と◎◎◎" というように複数領域が指定される。 ちなみに、Range("○○○","△△△") と、2つの領域を、それぞれ " で囲んで記述すると、○○○ から △△△ という指定になる。 Set r = base.SpecialCells(xlCellTypeConstants) ● base という領域の中で、値（定数）が入っている領域を矩形の領域群として r に取得する。 この r に取得された領域群は、それぞれ r.Areas(1) とか r.Areas(2) といった記述で参照ができる。 For Each a In r.Areas ● r の中の領域群を1つずつ、a に取り出す If Intersect(base, a.CurrentRegion).Rows.Count < 3 Then ● 目的のブロックは行が3行以上必要なので、それ未満のものは、正規ブロックではないコメント等とみなして対象外。 Else Set a = adjustRange(Intersect(base, a.CurrentRegion)) ● 前述のとおり、 a.CurrentRegion で連続した上下の領域を1つにして、さらに左右の余分なとろころをそぎ落としたものが Intersect(base, a.CurrentRegion) 。 この領域を、さらに、ファンクションプロシジャ adjustRange に渡して、丸数字のある行を 1行目とした領域に加工。 If z Is Nothing Then Set z = a Else Set z = Union(z, a) End If ● z には 処理すべき各ブロック領域を格納する。最初はからっぽなので、最初の領域を単純にSet。2回目からは、それにUnionで追加。 For Each a In z.Areas ●処理すべきブロック領域が格納されている z から、それぞれの領域を 1つずつ a に取り出す。 Select Case a.Cells(1).Value Case "@" To "S" '念のため ●ブロックの1行目の1列目（ブロックの左上隅）が @からSのものだけを相手にする If a.Cells(2, 1).Value <> "NBT" Then slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End If ●NBTではないもののみを対象にする。 @からSのそれぞれの配列 slV の場所にブロックの場所を格納するとともに 変数 x に、ブロックの行数-2(ブロックのデータ数）を加算していく。 最終的には、変数 x は AW9 以降の転記行数になる。 ReDim v(1 To x, 1 To 5) ● 転記用配列 v を x行、5列で宣言する。 x = 1 For i = 1 To UBound(slV) ●配列の情報を1つずつ取り出し If Len(slV(i)) > 0 Then ●そこが空白ではない場合に処理。たとえば@はあるけど次がB（Aのブロックがない）といった場合、配列 v の 2番目の要素は からっぽなので処理しない。 With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) ●まず、そのブロックの領域、Range(slV(i)) の情報から、AW列、AZ列、BA列用の文字列をセット。 For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next ●続いて、AX列、AY列用データをセット。転記用配列 v 内の書き込み行番号 x は セット毎に 1 アップ。 With Range("AW1:BA7") w = .Formula .EntireColumn.ClearContents .Value = w End With ● AW1:BA7にある値を 変数 w に保存しておき、AW:BA列をクリアしたあと、それを戻す。 Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v ● AW8:BA8 のタイトル行をセットし、AW9からの転記用配列 v の大きさの領域に対して一括書込み。 Private Function adjustRange(a As Range) As Range ●領域を引数にして、その中で丸数字が表れる行より上の行をカットして、丸数字から始まる領域を呼び出し側に戻す ファンクションプロシジャ。 For Each c In a.Columns(1).Cells Select Case c.Value Case "@" To "S" Exit For End Select x = x + 1 Next ●与えられた領域の左端の列に@からSがあらわれるまでの行数が x に入る。 If a.Rows.Count = x Then Set adjustRange = a Else Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) End If ● x が この領域の行数と同じということは、丸数字がなかったということ。 この場合は、与えられた領域を、そのまま返す。 そうでない場合は、与えられた領域の x だけ下 Offset(x) で 行数が 元の行数より x だけ少ない数 Resize(a.Rows.Count - x) として、呼び出しがわに返す。 とりあえず、このあたりで。 桁チェックプロシジャについても必要かな? (ぶらっと) ---- 桁チェックも書いておくね。 Set dic = CreateObject("Scripting.Dictionary") ●Dictionary というVBAの外部の機能を呼び出し。 Dictionary は 辞書。キーとして見出し語、データとして、その見出し語に紐付く任意の情報が登録できる。 Dictionaryに対して見出し語を与えると、一発で、その登録内容の取得ができる。 With Sheets("マスタ") For Each c In .Range("A1").CurrentRegion.Columns(1).Cells ●シートの列から値のある最終行のセルまでを取り出す定番コード dic(c.Value & 0) = c.Offset(, 1).Value dic(c.Value & 1) = c.Offset(, 2).Value ●Dictionary に 見出し語として 型0 および 型1 というキーで、それぞれの制限半角文字数を登録 With Range("AY9", Range("AY" & Rows.Count).End(xlUp)) ●AY9 から AY列の最終データまでの領域を宣言。ここで With でくくっておけば、以降 End With までの間 その領域内の参照は .なんとか と、頭に .(ピリオド）をつけるだけで可能。 .Interior.ColorIndex = xlNone ●その領域全体の背景色を色なしに。 For Each c In .Cells ●その領域（.Cells) からセルを1つずつ取り出す。 '丸文字行ならキーを保存 If Len(c.Offset(, 2).Value) > 0 Then dkey = c.Offset(, 1).Value & c.Offset(, 2).Value ●もし、BA列、つまり、c.Offset(, 2) の値があれば、丸数字行なので、型とタテヨコのキーをあわせたものを保存 If dic.exists(dkey) Then ●もし、この 型+タテヨコでDictionary に登録があれば v = Split(c.Value, "|") ●そのデータを | で分解。結果は分解された文字列の部分が、分先された数だけを要素に持つ、0 から始まる1次元配列となる。 For Each d In v ●その分解された部分を1つずつ抽出 '半角ベースで桁チェック x = LenB(StrConv(d, vbFromUnicode)) ●エクセル上は、すべての文字が【UniCode】といわれる、2バイトコードでセットされている。 全角文字の A も 半角文字の A も バイト数としては 2。今回は、全角文字なら 2 、半角文字なら 1 と数える必要がある。 で、vbFromUnicode というパラメータを指定して StrConv をかけると、半角文字は 1バイトの、「本当の文字」に変わる。 それを LenB関数で調べるとバイト数が取得できる。 If x > dic(dkey) Then c.Interior.Color = vbRed '桁オーバー Exit For ●分解された文字列の1つでも、桁オーバなら、背景色を赤にしてループを抜け、次の行にうつる。 Else c.Interior.Color = vbYellow '登録無し ●Dictionaryの登録がなければ、マスタに登録がなかったということで、背景色を黄色にする。 (ぶらっと) ---- (ぶらっと)さん 詳しい解説、大変有難う御座います。 少しずつ自分のものにしたいと思っています。 大変感謝・感謝です。 (KJS) ---- 再度教えて頂きたい事が出来ました。 完全に確認した事では有りませんが A7,E7,I7の何れかに丸文字が入るブロックが有る場合 A5:C5,E5:G5,I5:K5,A6:C6,E6:G6,I6:K6 の 文字の入っているセルの組み合わせに依り 「実行時エラー 1004 アプリケーション定義またはオブジェクト定義のエラーです」 が表示され Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) の所が黄色に成りました。 下記が実行時エラーの出る場合の一例。 下記が出ない場合の一例。 ABC EFG IJK ABC EFG IJK 5 * 5 * 6 * 6 * ABC EFG IJK ABC EFG IJK 5 * 5 * 6 * 6 * ABC EFG IJK ABC EFG IJK 5 * * 5 * 6 * 6 * * ABC EFG IJK ABC EFG IJK 5 * 5 * 6 * 6 * 私の頭では、一貫性は見つけられません。 それからもう1点教えて下さい。 桁オーバー又は型式入力ミスによりデーター部に色が付きます。 変更して正しく直し、1つのブロックを削除した場合にはデーターは正しく表示されますが 変更前の色が残る場合が有ります。マクロを実行する時に全てクリアして再表示する事は出来ますか。 宜しくお願い致します。 (KJS) ---- とりあえず簡単な方（色が残るバグ）から。 桁チェック の .Interior.ColorIndex = xlNone を削除し With Range("AY9", Range("AY" & Rows.Count).End(xlUp)) の上に With ActiveSheet.UsedRange z = .Row + .Rows.Count - 1 End With Range("AY9:AY" & z).Interior.ColorIndex = xlNone この4行を追加して。 残りは明日にでも。 (ぶらっと) ---- 追申 こちらでは今のところエラーが再現しないので、明日、もう少し掘り下げてみるけど そちらでエラーになった時に、黄色く光っている Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) このコードの x にマウスを当てて浮かび上がる値を教えて。 それと、a.Rows.Count のところにもマウスをあてて、浮かび上がる値も教えて。 (ぶらっと) ---- お世話に成っています。 >このコードの x にマウスを当てて浮かび上がる値を教えて。 それと、a.Rows.Count のところにもマウスをあてて、浮かび上がる値も教えて。 操作方法が解りません。 標準モジュール内の コード(Sample5) の上記にマウスを当てれば、どこに表示されるのですか。 (KJS) ---- 黄色く光った状態で、目的の変数にマウスをあてると、マウスポインターの下あたりに何か浮かび上がらないかな? (ぶらっと) ---- 念のためなんだけど・・・ ずっと上のほうで、以下のレスをしているけど、対応してくれているんだよね・・・? (ぶらっと) プロシジャ adjustRange を以下のように入れ替えて。 Private Function adjustRange(a As Range) As Range Dim c As Range Dim x As Long For Each c In a.Columns(1).Cells Select Case c.Value Case "@" To "S" Exit For End Select x = x + 1 Next If a.Rows.Count = x Then Set adjustRange = a Else Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) End If End Function ---- VBE画面での変数の値のチェック等に関する参考 http://www.asahi-net.or.jp/‾ef2o-inue/vba_k/sub04_030_03.html http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vba_vbe.html (ぶらっと) ---- お世話に成っています。 x=2 a.Rows.Count=16 と表示します。 下記に 私の貼付・入れ替えが間違っているのか心配なので全て表記します。 Sub Sample5() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Dim slV(1 To 20) As String Dim base As Range Dim w As Variant Set base = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52") Set r = base.SpecialCells(xlCellTypeConstants) ' For Each a In r.Areas ' Set a = adjustRange(Intersect(base, a.CurrentRegion)) ' ' If z Is Nothing Then ' Set z = a ' Else ' Set z = Union(z, a) ' End If ' Next For Each a In r.Areas If Intersect(base, a.CurrentRegion).Rows.Count < 3 Then ' MsgBox "ブロックが対象のものではないか、不充分です" & vbLf & a.Cells(1).Value Else Set a = adjustRange(Intersect(base, a.CurrentRegion)) If z Is Nothing Then Set z = a Else Set z = Union(z, a) End If End If Next For Each a In z.Areas Select Case a.Cells(1).Value Case "@" To "S" '念のため If a.Cells(2, 1).Value <> "NBT" Then slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End If Case Else ' MsgBox "ブロック先頭の丸文字が認識できません" & vbLf & a.Cells(1).Value End Select Next ReDim v(1 To x, 1 To 5) x = 1 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next End With End If Next ' Columns("AW:BA").ClearContents With Range("AW1:BA7") w = .Formula .EntireColumn.ClearContents .Value = w End With Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v Call 桁チェック End Sub ' Private Function adjustRange(a As Range) As Range ' Dim c As Range ' Dim x As Long ' For Each c In a.Columns(1).Cells ' Select Case c.Value ' Case "@" To "S" ' Exit For ' End Select ' x = x + 1 ' Next ' Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) ' End Function Private Function adjustRange(a As Range) As Range Dim c As Range Dim x As Long For Each c In a.Columns(1).Cells Select Case c.Value Case "@" To "S" Exit For End Select x = x + 1 Next If a.Rows.Count = x Then Set adjustRange = a Else Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) End If End Function Sub 桁チェック() Dim dic As Object Dim c As Range Dim dkey As String Dim v As Variant Dim d As Variant Dim x As Long Set dic = CreateObject("Scripting.Dictionary") With Sheets("マスタ") For Each c In .Range("A1").CurrentRegion.Columns(1).Cells dic(c.Value & 0) = c.Offset(, 1).Value dic(c.Value & 1) = c.Offset(, 2).Value Next End With With Range("AY9", Range("AY" & Rows.Count).End(xlUp)) .Interior.ColorIndex = xlNone For Each c In .Cells '丸文字行ならキーを保存 If Len(c.Offset(, 2).Value) > 0 Then dkey = c.Offset(, 1).Value & c.Offset(, 2).Value If dic.exists(dkey) Then v = Split(c.Value, "|") For Each d In v '半角ベースで桁チェック x = LenB(StrConv(d, vbFromUnicode)) If x > dic(dkey) Then c.Interior.Color = vbRed '桁オーバー Exit For End If Next Else c.Interior.Color = vbYellow '登録無し End If Next End With End Sub (KJS) ---- う〜ん・・・ コード自体は最新版だねぇ。 もしかしたら・・・・提示してもらったケースとは関係なく、ずっとシートの下のほうにゴミがある? だめもとで、 Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x) これを Set adjustRange = a.Resize(a.Rows.Count - x).Offset(x) こうかえてもエラーになる? (ぶらっと) ---- はい、同じでした。 Set adjustRange = a.Resize(a.Rows.Count - x).Offset(x) が黄色に成りました。 (KJS) ---- う〜〜〜ん・・・・・・ >x=2 >a.Rows.Count=16 と表示します。 この値を Set adjustRange = a.Resize(a.Rows.Count - x).Offset(x) に適用すると Set adjustRange = a.Resize(16- 2).Offset(2) つまり Set adjustRange = a.Resize(14).Offset(2) これで、1004 アプリ定義エラーになるとすれば・・・う〜ん わからないなぁ。 確認のため adjustRange で Dim v As String これを追加して Set adjustRange = a.Resize(a.Rows.Count - x).Offset(x) この上に、 v = a.Address といれて、今度、きいろく光ったら、上の行の v = a.Addre の v にマウスをあてて 浮かび上がり文字列を教えてくれる? (ぶらっと) ---- いまふと・・・ エラーの出るケースの、たとえば ABC EFG IJK 5 * 6 * このときの このあたりのセルの結合状態はどうなっている? (ぶらっと) ---- 追記 きいろく光った時 v = a.Address の v の値に加えて Set adjustRange = a.Resize(a.Rows.Count - x).Offset(x) この a.Rows.Count と x の値も教えてね。 (ぶらっと) ---- セルの結合が有っても、無くともエラーが出ます。 A5,A6 B5,A6 C5,A6 A5,B6 B5,B6 C5,B6 A5,C6 B5,C6 C5,C6 に文字が入っていればエラーが出ます。 >きいろく光った時 v = a.Address の v の値に加えて 黄色に成ってとき v = a.Address はどこにあるか解りません。 a.Rows.Count =アプリケーション定義またはオブジェクト定義のエラー と表示します。 X=2 です。 (KJS) ---- >黄色に成ってとき v = a.Address はどこにあるか解りません。 上でレスした以下をコードに追加して試してもらいたかったんだけど。 >確認のため adjustRange で Dim v As String これを追加して >Set adjustRange = a.Resize(a.Rows.Count - x).Offset(x) >この上に、 v = a.Address といれて、今度、きいろく光ったら、上の行の v = a.Addre の v にマウスをあてて >浮かび上がり文字列を教えてくれる? とにかく、こちらで何とかして再現したいので。 (ぶらっと) ---- >a.Rows.Count =アプリケーション定義またはオブジェクト定義のエラー と表示します。 あっ、これは新情報だね。この線でも少しチェックしてみるね。 (ぶらっと) ---- とにかく、いろいろ、（無理矢理）例外的なデータを作って試してみている。 指摘のあった場所ではなく、別の場所（状況によって場所は異なる）でエラーで止まることはありえるね。 たとえば、シートにちゃんとした丸文字ブロックが1つもない場合。 それから、たとえば A5,A6に丸文字ブロックとは別の値があってA7に丸文字。だけど、A8以降がない。 せめてここはチェックでスキップすべきだけど、この場合もエラーでとまる。 ただし、指摘の場所ではないのが・・・・???だけど。 今回指摘の原因がわかれば、そこと一緒に、↑で発見したバグは修正するけど・・・ そちらの、A5,A6に値があってエラーになるケースだけど、A4やB列はどうなっている? また、A7,A8,A9はどうなっている? で、シートのその固まり以外を空白にして実行するとどうなる? (ぶらっと) ---- >上の行の v = a.Addre の v にマウスをあてて浮かび上がり文字列を教えてくれる? a.Addre ="$A$5:$C$16,$E$5:$G$16,$I$5:$K$16" と表示します。 >A5,A6に値があってエラーになるケースだけど、A4やB列はどうなっている? A4:C4を空白にするとエラーは出ません。 A7 @ A8 NKT A9 1 です。 (KJS) ---- a のアドレスが複数領域!!! コードは、ここが単一領域であることを前提にしている。 Sample4 をアップしたとき、以下のコメントを書いたけど覚えているかな? >(実はこれでも不十分なケースあり。5行目から始まるブロックが複数あり、4行目に値のあるセル（群）がその複数のブロックに >ともに接触するようなケースは、一番左のブロックのみが抽出される。このような場合も想定するコードも書くことができるけど >面倒なので、できるだけ Saample3のままにしてある） つまり、4行目にずらっと値のあるセルが連続していて A:C列、E:G列、I:K列の5行目から始まる別ブロックが 連結されちゃっている状態。 Sample4アップ次のコメント通り、コードとしては対応していないので、できれば4行目は空白行にしておいてほしい。 （5行目が空白で6行目からの固まりなら4行目に連続した値が入っていてもいいんだけどね） いやだ!4行目にも任意に値を入れるんだ!そして、5行目からも値を入れるんだ! ということなら、ちょっと考えてみるけど・・・ ちょっと時間かかりそうだよ。 (ぶらっと) ---- 今回の調査中に発見した他の不具合も解消。 adjustRange と 桁チェック は変更無し。 ★ただし、4行目と5行目が結合されているセルはないということが前提。 それさえ守ってもらえれば1〜4行目に値があろうがなかろうがOK。 Sub Sample6() Dim r As Range Dim a As Range Dim z As Range Dim sl As Object Dim i As Long Dim x As Long Dim v() As Variant Dim slV(1 To 20) As String Dim base As Range Dim sv As Variant Dim cols As Long Application.ScreenUpdating = False Set base = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52") On Error Resume Next Set r = base.SpecialCells(xlCellTypeConstants) On Error GoTo 0 If r Is Nothing Then MsgBox "処理すべきブロックがありません" Exit Sub End If With ActiveSheet.UsedRange cols = .Column + .Columns.Count - 1 End With With Range("A1", Cells(4, cols)) sv = .Formula .ClearContents End With For Each a In r.Areas Set a = adjustRange(a.CurrentRegion) If z Is Nothing Then Set z = a Else Set z = Union(z, a) End If Next For Each a In z.Areas Select Case a.Cells(1).Value Case "@" To "S" '丸数字ブロックのみ対象 If a.Rows.Count > 2 Then 'データ行がない場合は処理せず If a.Cells(2, 1).Value <> "NBT" Then slV(Asc(a.Cells(1).Value) - Asc("@") + 1) = a.Address x = x + a.Rows.Count - 2 End If End If End Select Next If x = 0 Then Range("A1", Cells(4, cols)).Value = sv MsgBox "処理すべきブロックがありません" Exit Sub End If ReDim v(1 To x, 1 To 5) x = 1 For i = 1 To UBound(slV) If Len(slV(i)) > 0 Then With Range(slV(i)) v(x, 1) = .Cells(1).Value v(x, 4) = .Cells(2, 1).Value & .Cells(2, 2).Value v(x, 5) = IIf(.Cells(1, 2).Value = "ヨコ", 0, 1) For Each r In .Offset(2).Resize(.Rows.Count - 2).Rows v(x, 2) = r.Cells(1, 1).Value v(x, 3) = r.Cells(1, 2).Value & r.Cells(1, 3).Value If Len(v(x, 3)) = 0 Then v(x, 3) = "_" x = x + 1 Next End With End If Next Columns("AW:BA").ClearContents Range("AW8:BA8").Value = Array("丸番号", "番号", "データー", "型式", "方向") Range("Aw9").Resize(UBound(v, 1), UBound(v, 2)).Value = v Call 桁チェック Range("A1", Cells(4, cols)).Value = sv End Sub (ぶらっと) ---- Sample6 はまだ確認していませんが、 A1:T4 の使用状況を記入します。 ホーマットとして 下記の結合セルが有り文字が入ります。 [A1:K2] [M1:O1] [Q1:S1] [F3:G4] [I3:I4] [J3:K4] [M3:M4] [N3:N4] [O3:O4] [S3:T4] 他に ブロック（丸文字の有る行）が7行から始まるの場合には、[A5:C5] [A6:C6] [E5:G5] [E6:G6] [I5:K5] [I6:K6] [M5:O5] [M6:O6] [Q5:S5] [Q6:S6] の結合セルが有る場合も有ります。 それから、A3,B3,C3,A4,B4,C4 セルには 文字が入る場合、無い場合が有ります。 (KJS) ---- 問題は、4行目に値のあるセルがずらっと連続して、ブロックが存在する3つずつの複数の列群に【ブリッジ】のようにかかり かつ、そのブリッジで連結された少なくとも1つの列群に固まりが5行目から存在した場合の不具合。 Sample6 はそれを解消。 ただし、4行目と5行目にまたがって結合されたセルがないということが前提。 このようなセルがあった場合、プロシジャの先頭のほうの .ClearContents で実行時エラーになる。 (ぶらっと) ---- (ぶらっと)さん いろいろな条件を後出ししてしまいまして大変申し訳なく思っております。 「4行目と5行目にまたがって結合されたセルがない」ので Sample6 を使わせて頂きます。 大変なご苦労を御掛け致しました。 大変有り難う御座いました。 (KJS)... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201212/20121216091746.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97013 documents and 608132 words.
訪問者：