[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『配列を変えて表示したい』（KJS） Excel2003 WindowsXPです。
資料 (A5:S52) を (AW:BA列) に表示したいのですが
*1 丸番号は ①～⑳ が必要なものだけランダムに配置されています。
例) 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 セルに ③ が有るが、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 ② タテ
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 ③ ヨコ 12 ② 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 ⑪ 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 ⑪ ヨコ 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
上記の様に表示したいのですが、宜しく御教授下さい。
いくつか質問
１．ランダムにと言うことだから開始行や開始列、その行数は決まっていないということだね？ あるいは、列はきまっている？ ２．それらブロックが存在する場所は A列～AV列のどこかにあるということでいいのかな？ ３．最大５０ブロックということだけど、ブロックの順番は、どのように決める？ ○数字で決めるの？ それとも？
(ぶらっと)
説明不足で申し訳有りません。
１・丸文字の有る列は A列、E列、I列、M列、Q列と決まっています。 行は決まっていません。 ２・ブロックは、 A5～S52 の範囲内です。 ３・ブロック数は最大２０です。又順番は丸番号の若い順でと思っています。 (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 が搭載されていればＯＫだけど）
タテとヨコのコードについては
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 "⑳" '念のため
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. ①ブロックと②ブロックが表示しません ③と⑪ブロックは表示します。
2. >*5 丸番号の下のセルに NBT と表記されていればそのブロックは (AW:BA列) に表示しない。
③の下のセルが NBT と表記されているのに ③ブロックが表示している。
3. >データーが無い(空白)の場合には _ (アンダーバー)を表示
例) F43:G45 にはデーターが無いので AY30:AY32 に アンダーバーを表示したい。
宜しくお願い致します。 (KJS)
> 1. ①ブロックと②ブロックが表示しません ③と⑪ブロックは表示します。
後述
> 2. >*5 丸番号の下のセルに NBT と表記されていればそのブロックは (AW:BA列) に表示しない。
③の下のセルが NBT と表記されているのに ③ブロックが表示している。
失念してた。ごめん。
> 3. >データーが無い(空白)の場合には _ (アンダーバー)を表示
例) F43:G45 にはデーターが無いので AY30:AY32 に アンダーバーを表示したい。
了解。
ということだけど、１．がわからないねぇ。こちらでは、①も②も表示されているので。 そちらのシート上の①や②が、コードでチェックしている①や②と合致しない？ ブロック先頭のセルの丸文字の前や後にスペースなんかがあれば、それは、マッチしないけどね。
コードで認識していないものがあった場合メッセージを出すように仕掛けたので、どんなめっせーじがでるか（あるいはでないのか） 確認してくれる？
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 "⑳" '念のため
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)
②ブロックを I5:K14 から I6:K15 へ移動したら ①も②も表示しました。
(KJS)
>「ブロック先頭の丸文字が認識でこません」 の表示が出ました。 >②ブロックを I5:K14 から I6:K15 へ移動したら ①も②も表示しました。
もう一度、②ブロックを元の場所に戻し、「ブロック先頭の丸文字が認識でこません」 のメッセージの下の行にでている その先頭文字が何であったか教えてくれる？
このコードはシートの該当の列の【値が入力されている固まり】を抽出し、その固まりの左上に①や②が あるはずと思っているけど、たとえば、①の上にあるセルに、式が入っていて式の結果で "" となっているような場合 これがブロックの先頭と見なされ、その値が "" (長さ0の文字列）と見なされて対象外になる。
なにかしら、ブロックの回りに空白と見えて空白ではないセルが存在するとしか思えないけどね。
(ぶらっと)
ご苦労をお掛けしています。
>その先頭文字が何であったか教えてくれる？ TB.デバイス と表示しています 尚そこは A1:K2 の結合セルです。
A1からT4 に結合セルが数個有ります。 Q1:S1 B3:C3 F3:G4 I3:I4 J3:K4 S3:T4 が結合セルです。
②の上 I3:I4 の結合セルを解除すると表示出来ました。 この事が関係有りますか。
追記 上で書き方が間違っていました。 「ブロック先頭の丸文字が認識でこません」 →「ブロック先頭の丸文字が認識できません」 でした。
(KJS)
ＶＢＡ処理で結合セルがある場合は、それなりのコードにする必要があるところが多々あるよ。 それと、アップしたコードはシート上には、このブロック以外は空白という前提だけど、そうじゃないんだね？ さらに、ブロックの回りは空白行、空白列で囲まれているということが前提。 たとえば②のブロックの上は空白行だと思っている。そうじゃなく、そこには、何か、ブロックとは関係のないものが 記入されたセルがあるんだね？（結合であれ、通常のセルであれ）
もしそうなら、ブロックがどこからどこまでかを判定することが、場合によっては無理になるよ。
まぁ、がらっと方法を変えて①～⑳の文字が記入されているセルを探し出し、そこがブロックの左上という 判定もできなくはないけど、それでも、ブロックの左右や下に、何か別の項目があれば、それもできなくなる。
一番確実なのは、ブロックの回りには値のあるセルがないということだけど、シートレイアウトを、そのようにできる？
あるいは・・・ブロックは５行目以下ということでＯＫなら現在のコードを少しかえるだけですむけど。 (この場合、１～４行目までには、結合セルがあろうが、値のあるブロック以外のセルがあろうがＯＫ）
追記）↑ あぁ、そう書いてあったね。ブロックは５行目以下。 じゃぁ、なんとかできるな。 コードは明日になるのでしばしお待ち乞う。
(ぶらっと)
説明のあったレイアウトを踏まえると、結合セル、単一セルということではなく、４行目に値が入っていないか 入っていたとしても、そのセル（結合セルあるいは単一セル）が５行目以降のブロックと【接触していなければ】 Sample3でＯＫだけど、実際にはそうではないようなので、以下。 (実はこれでも不十分なケースあり。５行目から始まるブロックが複数あり、４行目に値のあるセル（群）がその複数のブロックに ともに接触するようなケースは、一番左のブロックのみが抽出される。このような場合も想定するコードも書くことができるけど 面倒なので、できるだけ 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 "⑳" '念のため
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 ロジック変更は無いけど、ちょっとだけコードをスリム化。
>どうすれば良いですか。
う～ん・・・ 仕様上の【お約束】として、５行目から↓には【ブロックしかない】ということにしているので。 そのブロックの中で丸文字が存在するところの上の部分はブロックの対象ではないということなら以下。 ただし、たとえば、ブロックの下にも連続してブロックではない部分があったとき、それはブロックには含めない ということは不可能。
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 "⑳" '念のため
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 "⑳"
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のところに１行追加
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
これでＯＫだと思うよ。
(ぶらっと)
(ぶらっと)さん お世話に成りました。
最後の最後まで面倒を見ていただきまして大変有り難う御座います。 感謝でいっぱいです。
(KJS)
(ぶらっと)さん 使用して追加の質問が出来ました。
(AZ:BA列) の型式・方向によってデーターの最大桁数が決まっています。 (A5:S52)の資料を作る時点で桁数オーバーの場合には、パイプ（縦棒の様な記号）を使い ２行に印字する様にしていますが、資料作成ミス等に依る桁数オーバーの場合に AY列の該当セルに色を塗る等 目で見て解る様に表示出来ないでしょうか。（パイプが有ると２行に印字するソフトを使用している） わがまま言って大変申し訳有りません。
「型式に依る最大半角文字数」
型式 ヨコ タテ
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 ② タテ
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 ② 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列のことかな？
すみません。実際使用してブロックの下の１行のスペースは無い方が良いと思いました。 (KJS)
この制限情報は、どこで規定しようか？ どこかのシートにテーブルとして持たせてある？ コードの中でテーブルを作り出してもいいけど、追加変更があった場合にコードを修正しなきゃいけないので マスターシートのようなものを作っておいた方がいいと思うけど。
>実際使用してブロックの下の１行のスペースは無い方が良いと思いました。
了解。
(ぶらっと)
とりあえず "マスタ" というシートを準備しよう。 １行目がタイトル（型式、ヨコ、タテ とか） ２行目から A列が型、Ｂ列が横の桁数、Ｃ列が縦の桁数 桁数は半角換算）
アップ済みのコードの処理が終わった後のできあがりシートに対して単独に実行してもいいし 同時に行うなら、Sample5 の End Sub の直前に Call 桁チェック と、１行追加。
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
この１行を消すか、先頭に ' をつけてコメントにすれば、メッセージはでなくなるよ。 処理には影響がないので、メッセージが不要ならどうぞ。
(ぶらっと)
申し訳有りません。 私の説明が下手で正確に伝えられませんでした。
たとえば ブロックに全然関係の無い セルR20 に文字が有る場合 マクロを実行すると 「実行時エラー '10047'; アプリケーション定義またはオブジェクト定義のエラーです。」が表示され 「Set adjustRange = a.Offset(x).Resize(a.Rows.Count - x)」の所が黄色に成る事でした。
(KJS)
あぁ、ごめん、ごめん。バグだった。 ブロックそのものであろうと、ブロック以外のものであろうと【そこが１行】のときの不具合。 さらに、今回の不具合で気がついたバグ有り。正常な（つもりの）ブロックが先頭の２行しかない場合も 別のところでエラーになる。
以下の対応をお願い。
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 "⑳"
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。
(ぶらっと)
(ぶらっと)さん 大変有難う御座います。 １週間以上教えて頂きまして感謝申し上げます。
最後に わがまま言って申し訳有りませんが マクロの解説をお願い出きれば幸いです。
(KJS)
>マクロの解説をお願い出きれば幸いです
(KJS)さんのVBAレベルがどうかによって、コード解説より、ポイントとなる処理の説明にとどめた方が よりわかりやすいかもしれないと、ちょっと悩んだりしている。 一定のレベルにある人に対して、わかりきったコードを逐一解説するのも、かえって読みづらくなるだろうし。
まず、いくつか、この処理で使っている機能について。（必要なら、コードの解説もアップするよ）
・規定領域内のブロックの取得
Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52")
この中で、連続して値があるところを抽出している。これが、Set r = base.SpecialCells(xlCellTypeConstants)
ただ、この処理で、やりにくいところは１つ。結果は、連続した矩形の領域になるんだけど、たとえば この領域に
① ヨコ NAT -440 1 1 0 2 1 P 3 1 Q
こんなものがあったとする。で、領域として ① から Q までの 5行3列の取得ができればいいんだけど 実際には、①～-440 までの2行2列 と 1～Q までの3行3列 の２つの領域にわかれてしまう。
なので、それぞれの領域.Creentregion の領域を取得。（これで、希望の 5行3列 の領域になる） ２つの領域がそれぞれ、同じ CreentRegion を持つけど、同じものを Union で結合させれば、上書き（じゃないけど）のような感じで １つだけになる。
新規ブックのシートの任意の場所に上記データを書き込み、この 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 なので使えず、苦肉の策で ２０個の要素を持つ１次元配列を用意。(slV) １番目が ①、２０番目が⑳ （要素番号は ①～⑳ に対する文字コード から算出） ここにブロックの領域アドレスを格納して、最後に、この配列の上から順に領域を参照して、転記用配列（v)に上からセット。 slVからの取り出しが終了したら、v からセルに一挙に転記。
・桁チェック
マスタシートから 型0 型1 について それぞれの半角文字制限数をDictionaryに登録。 AY9から始まる転記領域のそれぞれの記載内容を | で分解して、分解された、それぞれの文字列の桁数と Dictionaryに登録された文字数とを淡々と比較し、桁オーバなら色塗り。
(ぶらっと)
(ぶらっと)さん 大変有難う御座います。
コードの解説をお願い致します。
高年齢でVBA超初級の私ですが、コードの解説をやっていただき勉強したいと思います。
(KJS)
コード解説の前に、↑でいいわすれたこと。
２つの領域に分かれたものを、その領域.CurrentRegion にして、連続しているそれらを a.CurrentRegion で１つの領域にしていると 説明したけど、さらに、それを、そのまま使わず、Intersect(base, a.CurrentRegion) というもので加工している。 Intersect は、指定領域が重なったところという意味だけど、a.CurrentRegion は、連続した上下のみならず、左右に連続した値があるセルも 取り込んでしまう。なので、その左右にくっついた領域があったとしても、base という ブロックが存在可能領域と Intersect することで、 左右の余分な領域（体脂肪のようなもの？）をそぎ落としている。
さて、コード。ポイントかなと思われるところのみコードの下に●印で説明。
Dim v() As Variant
●配列を宣言。ただし大きさについては、ここでは未確定という () 宣言。 こういった配列を「動的配列」と呼び、大きさが決まった時点で Redim で規定を行う。
Dim slV(1 To 20) As String
●①から⑳のブロックの領域情報を格納する配列。
ちなみに、①は、コードで言えば -30912。これは ASC("①") で取得可能。
また、⑳は -30893。 ①から⑳のコードは、1ずつ増えていく。
なので、ASC(丸文字)-ASC("①")+1 のコードで、①が 1、⑳が 20 という番号が取得できる。
Set base = Range("A5:C52,E5:G52,I5:K52,M5:O52,Q5:S52")
● Range("○○○,△△△,□□□,・・・・,◎◎◎") このように ( ) の中の先頭と最後のみに " がある場合
○○○と△△△と□□□と・・・・と◎◎◎" というように複数領域が指定される。
ちなみに、Range("○○○","△△△") と、２つの領域を、それぞれ " で囲んで記述すると、○○○ から △△△ という指定になる。
Set r = base.SpecialCells(xlCellTypeConstants)
● base という領域の中で、値（定数）が入っている領域を矩形の領域群として r に取得する。 この r に取得された領域群は、それぞれ r.Areas(1) とか r.Areas(2) といった記述で参照ができる。
For Each a In r.Areas
● r の中の領域群を１つずつ、a に取り出す
If Intersect(base, a.CurrentRegion).Rows.Count < 3 Then
● 目的のブロックは行が３行以上必要なので、それ未満のものは、正規ブロックではないコメント等とみなして対象外。
Else
Set a = adjustRange(Intersect(base, a.CurrentRegion))
● 前述のとおり、 a.CurrentRegion で連続した上下の領域を１つにして、さらに左右の余分なとろころをそぎ落としたものが Intersect(base, a.CurrentRegion) 。 この領域を、さらに、ファンクションプロシジャ adjustRange に渡して、丸数字のある行を １行目とした領域に加工。
If z Is Nothing Then
Set z = a
Else
Set z = Union(z, a)
End If
● z には 処理すべき各ブロック領域を格納する。最初はからっぽなので、最初の領域を単純にSet。２回目からは、それにUnionで追加。
For Each a In z.Areas
●処理すべきブロック領域が格納されている z から、それぞれの領域を １つずつ a に取り出す。
Select Case a.Cells(1).Value
Case "①" To "⑳" '念のため
●ブロックの１行目の１列目（ブロックの左上隅）が ①から⑳のものだけを相手にする
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ではないもののみを対象にする。 ①から⑳のそれぞれの配列 slV の場所にブロックの場所を格納するとともに 変数 x に、ブロックの行数-2(ブロックのデータ数）を加算していく。 最終的には、変数 x は AW9 以降の転記行数になる。
ReDim v(1 To x, 1 To 5)
● 転記用配列 v を x行、5列で宣言する。
x = 1
For i = 1 To UBound(slV)
●配列の情報を１つずつ取り出し
If Len(slV(i)) > 0 Then
●そこが空白ではない場合に処理。たとえば①はあるけど次が③（②のブロックがない）といった場合、配列 v の ２番目の要素は からっぽなので処理しない。
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 "⑳"
Exit For
End Select
x = x + 1
Next
●与えられた領域の左端の列に①から⑳があらわれるまでの行数が 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 というＶＢＡの外部の機能を呼び出し。 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) からセルを１つずつ取り出す。
'丸文字行ならキーを保存
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 から始まる１次元配列となる。
For Each d In v
●その分解された部分を１つずつ抽出
'半角ベースで桁チェック
x = LenB(StrConv(d, vbFromUnicode))
●エクセル上は、すべての文字が【UniCode】といわれる、２バイトコードでセットされている。 全角文字の Ａ も 半角文字の A も バイト数としては 2。今回は、全角文字なら 2 、半角文字なら 1 と数える必要がある。 で、vbFromUnicode というパラメータを指定して StrConv をかけると、半角文字は 1バイトの、「本当の文字」に変わる。 それを LenB関数で調べるとバイト数が取得できる。
If x > dic(dkey) Then
c.Interior.Color = vbRed '桁オーバー
Exit For
●分解された文字列の１つでも、桁オーバなら、背景色を赤にしてループを抜け、次の行にうつる。
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 *
私の頭では、一貫性は見つけられません。
それからもう１点教えて下さい。 桁オーバー又は型式入力ミスによりデーター部に色が付きます。 変更して正しく直し、１つのブロックを削除した場合にはデーターは正しく表示されますが 変更前の色が残る場合が有ります。マクロを実行する時に全てクリアして再表示する事は出来ますか。
宜しくお願い致します。
(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
この４行を追加して。
残りは明日にでも。
(ぶらっと)
追申
こちらでは今のところエラーが再現しないので、明日、もう少し掘り下げてみるけど そちらでエラーになった時に、黄色く光っている
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 "⑳"
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 "⑳" '念のため
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 "⑳"
' 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 "⑳"
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 =アプリケーション定義またはオブジェクト定義のエラー と表示します。
あっ、これは新情報だね。この線でも少しチェックしてみるね。
(ぶらっと)
とにかく、いろいろ、（無理矢理）例外的なデータを作って試してみている。 指摘のあった場所ではなく、別の場所（状況によって場所は異なる）でエラーで止まることはありえるね。
たとえば、シートにちゃんとした丸文字ブロックが１つもない場合。 それから、たとえば 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 をアップしたとき、以下のコメントを書いたけど覚えているかな？
>(実はこれでも不十分なケースあり。５行目から始まるブロックが複数あり、４行目に値のあるセル（群）がその複数のブロックに >ともに接触するようなケースは、一番左のブロックのみが抽出される。このような場合も想定するコードも書くことができるけど >面倒なので、できるだけ Saample3のままにしてある）
つまり、４行目にずらっと値のあるセルが連続していて A:C列、E:G列、I:K列の５行目から始まる別ブロックが 連結されちゃっている状態。 Sample4アップ次のコメント通り、コードとしては対応していないので、できれば４行目は空白行にしておいてほしい。 （５行目が空白で６行目からの固まりなら４行目に連続した値が入っていてもいいんだけどね）
いやだ！４行目にも任意に値を入れるんだ！そして、５行目からも値を入れるんだ！
ということなら、ちょっと考えてみるけど・・・ ちょっと時間かかりそうだよ。
(ぶらっと)
今回の調査中に発見した他の不具合も解消。 adjustRange と 桁チェック は変更無し。
★ただし、４行目と５行目が結合されているセルはないということが前提。 それさえ守ってもらえれば１～４行目に値があろうがなかろうがＯＫ。
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 "⑳" '丸数字ブロックのみ対象
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]
他に ブロック（丸文字の有る行）が７行から始まるの場合には、[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)
問題は、４行目に値のあるセルがずらっと連続して、ブロックが存在する３つずつの複数の列群に【ブリッジ】のようにかかり かつ、そのブリッジで連結された少なくとも１つの列群に固まりが５行目から存在した場合の不具合。 Sample6 はそれを解消。
ただし、４行目と５行目にまたがって結合されたセルがないということが前提。 このようなセルがあった場合、プロシジャの先頭のほうの .ClearContents で実行時エラーになる。
(ぶらっと)
(ぶらっと)さん いろいろな条件を後出ししてしまいまして大変申し訳なく思っております。
「４行目と５行目にまたがって結合されたセルがない」ので Sample6 を使わせて頂きます。
大変なご苦労を御掛け致しました。 大変有り難う御座いました。
(KJS)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.