[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『読点の数だけ、下に行を追加する』（aki）
こんばんわ よろしくお願いします。
以下のような表があります。
_____[A]_____ _____[B]_____ [1] [2] A店 りんご、バナナ [3] B店 もも [4] C店 メロン、イチゴ、サクランボ [5] D店 なし、レモン [6] E店 すいか [7] [8] [9] [10] A店 りんご、バナナ [11] [12] B店 もも [13] C店 メロン、イチゴ、サクランボ [14] [15] [16] D店 なし、レモン [17] [18] E店 すいか
A2、B2にデータが入っており、B列に含まれる、読点の数だけ下に行を 挿入したいのですが、このようなことは可能なんでしょうか。 例えば、A2には、1つなので1行、B4には2つなので、2行 結果として、A10以降のような形にしたいのです。 宜しくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
追加のヒント。
上から下に実行していくと、
挿入された行によって未処理の行数が変わってしまって面倒。
こうした場合は、下から上に実行するとまぎれがありません。
・6行目を判定。挿入不要。
・5行目を判定。ひとつあるので、(5+1)行目に1行挿入。
・4行目を判定。ふたつあるので、(4+1)行目に2行挿入。
こんな要領です。
"、"の数のカウントは、例えば、Len(s) - Len(Replace(s,"、",""))
挿入のコードは、マクロ記録をとるとよいかもしれない。
ご自分で少しトライして、できるところまで示して、
また意見を聞いてみるようにしたらよいでしょう。
（γ） 2016/07/24(日) 07:15
作業列、使いまくりで、かつ、表示は F列、E列 になりますが。
C2 : 2 、 D2 : 2
C3 : =LEN(B3)-LEN(SUBSTITUTE(B3,"、",""))+1 D3 : =C2+D2
C3:D3を下にフィルコピー
E2 : =IFERROR(INDEX(A:A,MATCH(ROW(),$D:$D,0)),"") これをF2にフィルコピーし、そのまま下にフィルコピー。
不得意な数式処理なので、どこかに抜けもあるかもしれませんが。
（β） 2016/07/24(日) 07:46
只今、出張中のため、帰宅後、勉強させていただきます。 有難うございます。 （aki） 2016/07/26(火) 07:32
色々ご教示ありがとうございました。 結果としては、全てマクロでできませんでしたが、
C列に=LEN(B2)-LEN(SUBSTITUTE(B2,"、",""))+1 を入力し
Sub 行挿入()
For i = Range("C" & Rows.Count).End(xlUp).Row To 1 Step -1
temp = Fix(Val(Cells(i, "C").Value))
If temp > 0 Then Rows(i + 1).Resize(temp).Insert
Next
End Sub
の組み合わせで何とかなりました。 しかしながら、数式をその都度計算しているので、時間はかかってしまいます、、、 もう少し頑張ります。ありがとうございます。
（aki） 2016/07/27(水) 03:24
すでに完成されていると思います。素晴らしい。
なお、下記のようにすると、作業列をつかわずに済みますね。 参考まで。
Sub 行挿入()
Dim i As Long
Dim s As String
Dim temp As Long
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
s = Cells(i, 2).Value
temp = Len(s) - Len(Replace(s, "、", ""))
'temp = Fix(Val(Cells(i, "C").Value))
If temp > 0 Then Rows(i + 1).Resize(temp).Insert
Next
End Sub
挿入処理は結構コストのかかる処理ですので、 データが大量にあると、ある程度時間はかかるものとお考え下さい。
（γ） 2016/07/27(水) 05:00
γさん同様、感服です。
マクロ内でFor/Nextループに入る前に
Application.ScreenUpdating = False
これを記述しておくと、処理時間は若干、短縮化されると思います。
追記）今回は、γさんのコメントにあるように作業列をなくし、マクロ内で カンマ数を取得することで不要になりますが シート上に数多くの計算式がある場合、その参照セルの変更のつど、再計算が行われます。 計算式の数によっては、これも処理の足を引っ張る要因になります。
なので、ループに入る前、マクロの最初に
Application.Calculation = xlCalculationManual これを記述して
再計算を抑止します。
で、この設定は Application.ScreenUpdating とは異なり、マクロが終了しても
残りっぱなしになりますので、End Sub の前に、忘れずに
Application.Calculation = xlCalculationAutomatic を記述してください。
なお、Application.ScreenUpdating についても、そのタイミングで Application.ScreenUpdating = True と記述しておくほうが、わかりやすいですし お行儀の良いコードになりますね。
（β） 2016/07/27(水) 05:08
おはようございます。
再計算で時間がかかると言うのは、実際のデータは何万行くらいあるんでしょうか？ Insert はセルを直接操作するので、データ数が非常に多いと処理時間はどうしてもかかってしまいます。
そう言う場合は配列を使用すれば、劇的に処理時間が短縮されます。 ただ配列内での処理はそれなりに難しいのと、せっかくご自身で作ったコードと全然違う物になってしまうので、 まずはγさんやβさんのアドバイスを試してみて使えるなら、その方が良いと思います。
それでもどうしても遅くてきついと言う事でしたら、配列での方法も提示します。
（sy） 2016/07/27(水) 07:06
A B C D E 1 # 品名 挿入行数 2 100 りんご、バナナ 1 101 LEN(B2)-LEN(SUBSTITUTE(B2,"、","")) 3 200 もも 0 4 300 メロン、イチゴ、サクランボ 2 302 5 400 なし、レモン 1 401 6 500 すいか 0 7 600 、、、、、、、、、 9 609 8 700 なし、レモン 1 701 9 800 すいか 0 10 101 11 302 12 302 13 401 14 609 15 609 16 609 17 609 18 609 19 609 20 609 21 609 22 609 23 701 24
(aki)さんはVBAをご存知なので、VBAで処理すれば何でも(?)出来ますよね。
でも時間がかかり過ぎるのですよね? .Insertは特にね・・
そこで、考え方(処理の手順)を書いてみます。
1. A列に # を挿入する
2. Data最終行迄、10刻み 又は 100刻みで番号を振る
・上記は 100刻みの例："、"の最大数で刻み幅を調整
3. 追加開始行(上記の場合 Row=10)を得る
4. 挿入行数(品名：B列の "、"の数)を数える
5. 挿入行数が 0：Zeroでなければ
・A列 + 挿入行数の値を、その個数分追加開始行から追加する ・当然、追加開始行も Countupしておく
6. Data最終行迄の処理が終わり、#(A列)でSortすれば終了
・必要に応じて A列の削除
★この手順の、3 〜 5が比較的簡単なVBAでしょうか?
尚、上記の、C 〜 E列は参考迄に書いたものです。
（caro） 2016/07/28(木) 12:36
（β） 2016/07/24(日) 07:46 でレスした数式案ですけど、βは、もともと数式が苦手で Dictionaryと配列でこのテーマを処理するVBAコードを書いて、そのコードでやっていることを 無理やり数式に直して、回答案としました。
その時に書いたVBAコード、参考まで、以下アップしておきます。
Sub Sample()
Dim v As Variant
Dim dic As Object
Dim c As Range
Dim x As Long
Dim n As Long
Dim k As Variant
Dim w As Variant
Set dic = CreateObject("Scripting.Dictionary")
x = 1
For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
n = Len(c.Offset(, 1).Value) - Len(Replace(c.Offset(, 1).Value, "、", ""))
dic(c.Value) = Array(x, c.Value, c.Offset(, 1).Value)
x = x + n + 1
Next
ReDim v(1 To x, 1 To 2)
For Each k In dic
w = dic(k)
v(w(0), 1) = w(1)
v(w(0), 2) = w(2)
Next
Range("A2").Resize(UBound(v, 1), 2).Value = v
End Sub
（β） 2016/07/28(木) 12:53
こんな、無知無能な自分に
ありがとうございます。
一つずつ、自分なりに勉強させてください。 こんなに投稿していただき感謝申し上げます。 取り急ぎ御礼まで。 後日連絡させていただきます。 本当にありがとうございました。 （aki） 2016/07/28(木) 22:37
こんばんわ。
配列での方法を提示しておきます。 test1は元のデータが5万行くらいまでしか使えませんが、メンテナンスフリーです。 test2は、Const rowNo As Long = 50000 の 50000 を大きくすれば、5万行以上のデータも扱えます。 列数はA・B列以上の可能性もあると思いましたので、自動で最大列数を取得するようにしています。 ただ関数などがあれば、値に変換されてしまいます。
Sub test1()
Dim r
Dim cnt As Long
Dim buf() As String
Dim ia As Long
Dim ib As Long
Dim j As Integer
'変数に格納
r = Range("A2").CurrentRegion.Columns(2).Value
cnt = UBound(Split(Join(WorksheetFunction.Transpose(r), "、"), "、")) + 1
r = Range("A2").CurrentRegion.Value
ReDim buf(1 To cnt, 1 To UBound(r, 2))
'変数内で書き込み
ib = 1
For ia = 1 To UBound(r, 1)
For j = 1 To UBound(r, 2)
buf(ib, j) = r(ia, j)
Next j
ib = ib + UBound(Split(r(ia, 2), "、")) + 1
Next ia
'シートに書き出し
Range("A2").Resize(cnt, UBound(r, 2)).Value = buf
End Sub
Sub test2()
Const rowNo As Long = 50000
Dim r
Dim buf() As String
Dim ia As Long
Dim ib As Long
Dim j As Integer
'変数に格納
r = Range("A2").CurrentRegion.Value
ReDim buf(1 To rowNo, 1 To UBound(r, 2))
'変数内で書き込み
ib = 1
For ia = 1 To UBound(r, 1)
For j = 1 To UBound(r, 2)
buf(ib, j) = r(ia, j)
Next j
ib = ib + UBound(Split(r(ia, 2), "、")) + 1
Next ia
'シートに書き出し
Range("A2").Resize(rowNo, UBound(r, 2)).Value = buf
End Sub
（sy） 2016/07/28(木) 23:12
ご教示頂きました最初のもので動きましたので、取り急ぎこれを使用させていただきました。 ありがとうございました。落ち着いたら、順次勉強させていただく所存です。 話は変わりますが、以下のように変更できないものか、ご相談に参りました。 考え方をご教示頂きたく存じます。
_____[A]_____ _____[B]_____ [1] [2] A店 りんご、バナナ [3] B店 もも [4] C店 メロン、イチゴ、サクランボ [5] D店 なし、レモン [6] E店 すいか [7] [8] [9] [10] A店 りんご [11] A店 バナナ [12] B店 もも [13] C店 メロン [14] C店 イチゴ [15] C店 サクランボ [16] D店 なし [17] D店 レモン [18] E店 すいか
イメージといたしましては、行挿入した分だけA列を下にコピーし B列の2個目をその下に、3個目をさらにその下に挿入できればと考えています。 可能なのであれば、切り取りではなく、値として貼り付けカンマ以降を削除できれば一番理想です。 よろしくお願いします。 （aki） 2016/07/30(土) 18:00
可能ですので皆さんから回答があると思いますし、私も時間が取れたら書いてみますけど このレイアウト、結果を同じシートの１０行目から表示になっていますね。 ということは、元データは最大でも８行だけということでいいのですか？
元データの行数には制限を設けず、結果を別シートに展開するほうが、運用しやすいのではないでしょうか？
（β） 2016/07/30(土) 18:56
私の好みは↑のとおり、別シート展開ですが、とりあえず、γさんがアップされたコードを借用して 同じ場所で（つまり２行目から）対応するコードです。
Sub 行挿入2()
Dim i As Long
Dim s As String
Dim temp As Long
Dim w As Variant
Application.ScreenUpdating = False
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
s = Cells(i, 2).Value
temp = Len(s) - Len(Replace(s, "、", ""))
If temp > 0 Then
Rows(i + 1).Resize(temp).Insert
w = Split(s, "、")
Cells(i, 1).Resize(temp + 1).Value = Cells(i, 1).Value
Cells(i, 2).Resize(temp + 1).Value = WorksheetFunction.Transpose(w)
End If
Next
End Sub
（β） 2016/07/30(土) 19:10
こんばんわ。
元々のakiさんが作成されたコードや、皆さんの提示された方法やコードも、全て元のデータを変更するようになっていますが、 元データの下に複製を作って、今回のレイアウトのようになさりたいと言う事ですか？
仮に数万行あるとすれば、下に追記とすれば、かなりスクロールしなければいけないので、相当見づらくなると思います。 元のデータを残しておきたいのなら、βさんの言われるように別シート転記が良いと思います。
＞ご教示頂きました最初のもの これはβさんのDictionaryのコードでしょうか？ それともγさんが修正してくれたInsertのコードでしょうか？
以前にもお聞きしましたが、元データはどれくらいの行数あるんでしょうか？ 処理に時間がかかると言う事でしたので、相当な行数だと思うのですが？ βさんが再提示されたコードで速度的にも問題ないと言うのでしたら良いですけど、 ＞=LEN(B2)-LEN(SUBSTITUTE(B2,"、",""))+1 この数式ですと数万行くらいなら一瞬で計算されるはずなので、Insertで時間がかかってると思うんですが。
（sy） 2016/07/30(土) 19:56
(23:29) テストプロシジャといえ、あまりにも無様だったので入れ替えです。
データ件数が不明なんですが、確かに syさん指摘の通り、Insertはきわめて処理コストが重い処理です。 こちらで10万行のデータを作って、テストコードを走らせると戻ってこなかったので 1000行に減らして処理。
下記 Test1 、単純に各行の下に３行の行挿入をしているだけなんですが、それでも 当方環境で30秒。 （当方環境は、かなり性能がよろしい環境です）
一方、これに、数式もセットしたもので実行（Test2)しますと、85秒かかりました。 行挿入のつど数式が再計算されますので、これも道理かなと思います。
Sub Test1()
Dim i As Long
Dim t As Double
Cells.Clear
Range("A1:A1000") = "AAAA、BBBB"
'計測
t = Timer
For i = 1000 To 1 Step -1
Rows(i + 1).Resize(3).Insert
Next
MsgBox Timer - t
End Sub
Sub Test2()
Dim i As Long
Dim t As Double
Cells.Clear
Range("A1:A1000") = "AAAA、BBBB"
Range("B1:B1000").Formula = "=LEN(A1)-LEN(SUBSTITUTE(A1,""、"",""""))+1"
'計測
t = Timer
For i = 1000 To 1 Step -1
Rows(i + 1).Resize(3).Insert
Next
MsgBox Timer - t
End Sub
（β） 2016/07/30(土) 23:25
そこまで時間はかからないような気がしますが？
（マナ） 2016/07/30(土) 23:38
追加の質問の場合は、
速度面だけでなく、わかりやすさでも
配列を使用するほうが良い気がします。
Sub test()
Dim w(), v, s
Dim i As Long, j As Long, n As Long
ReDim w(1 To Rows.Count, 1 To 2)
v = Range("a1").CurrentRegion.Value
For i = LBound(v) To UBound(v)
s = Split(v(i, 2), "、")
For j = LBound(s) To UBound(s)
n = n + 1
w(n, 1) = v(i, 1)
w(n, 2) = s(j)
Next
Next
Range("a1").Offset(UBound(v) + 2).Resize(n, 2).Value = w
End Sub
（マナ） 2016/07/30(土) 23:57
>>そこまで時間はかからないような気がしますが？
まさしくです！！！ どうやら、10万件処理中に、強制終了させ、それも何度か繰り返した後に 1000件に減らしたんですが メモリーがグチャグチャになった状況だったかも。
今やってみると、Test1 は 0.6秒、Test2 は 1.2秒 ぐらいですね。 ただ、これを繰り返しますと 0.6 --> 0.9 --> 1.2 -->・・・ と、だんだん増加していきますね。
いずれにしても、
・そんなにはかからないけど、繰り返すと結構かかってしまう。 ・式がある場合は、その倍ぐらいかかる。
こんな状況です。
で、新しい要件処理の配列バージョンです。（今回は、配列のみで Dictionaryは使いませんでした）
Sub Sample2()
Dim c As Range
Dim v As Variant
Dim w As Variant
Dim n As Long
Dim a As String
Dim x As Long
Dim d As Variant
With Range("B2", Range("B" & Rows.Count).End(xlUp))
a = .Address
n = .Rows.Count + Evaluate("SUM(LEN(" & a & ")-LEN(SUBSTITUTE(" & a & ",""、"","""")))")
ReDim v(1 To n, 1 To 2) '挿入後のデータ格納配列
For Each c In .Cells
w = Split(c.Value, "、")
For Each d In w
x = x + 1
v(x, 1) = c.Offset(, -1).Value
v(x, 2) = d
Next
Next
End With
Range("A2:B2").Resize(UBound(v, 1)).Value = v
End Sub
（β） 2016/07/31(日) 00:04
↑ あっ！ ほとんど、マナさんのコードと【まんま】のコードでした。
（β） 2016/07/31(日) 00:06
情報が少なく申し訳ございません。 行数としては、約1万行で、元のデータを残し、別シートにて展開しております。 また、仰る通り、γさまのコードを使用させていただいております。
syさま ありがとうございます。
情報が少なく申し訳ございません。別シートに展開しております。
みなさまありがとうございます。
また進捗後、報告させていただきます。 よろしくお願いします。
（aki） 2016/07/31(日) 00:18
こんばんわ。
1万行ならtest1を変形させた方で使えるので、マナさんやβさんと被りますが、別シートに転記する案は考えていたので提示だけしておきます。
後余談ですけど、どちらも非常に高速なので気にするほどの差にならないですけど、 Len(s) - Len(Replace(s, "、", "")) より、UBound(Split(s, "、")) の方が倍くらい早いですね。
Sub test3()
Const sh1Name As String = "Sheet1"
Const sh2Name As String = "Sheet2"
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim ary
Dim r
Dim rowNo As Long
Dim buf() As String
Dim ia As Long
Dim ib As Long
Dim j As Integer
'変数に格納
Set sh1 = Sheets(sh1Name)
Set sh2 = Sheets(sh2Name)
r = sh1.Range("A2").CurrentRegion.Columns(2).Value
rowNo = UBound(Split(Join(WorksheetFunction.Transpose(r), "、"), "、")) + 1
r = sh1.Range("A2").CurrentRegion.Value
ReDim buf(1 To rowNo, 1 To UBound(r, 2))
'変数内で書き込み
ib = 1
For ia = 1 To UBound(r, 1)
ary = Split(r(ia, 2), "、")
For j = 0 To UBound(ary)
buf(ib, 1) = r(ia, 1)
buf(ib, 2) = ary(j)
ib = ib + 1
Next j
Next ia
'シートに書き出し
sh2.Range("A:B").ClearContents
sh2.Range("A2").Resize(rowNo, UBound(r, 2)).Value = buf
End Sub
（sy） 2016/07/31(日) 01:16
ところで、最初の私の対応が適当だったのかどうか、反省はあります。
下からという点にだけこだわってしまい、
全体として何をされたいのか、という視点がまるで落ちていました。
挿入するだけで済むわけはないですわねえ。
質問者さんも、最初からもう少し全体像を示してもらうとよかったかもしれませんね。
（γ） 2016/07/31(日) 09:33
今後ともよろしくお願いします。 （aki） 2016/07/31(日) 16:49
先日は大変お世話になりました。ありがとうございました。 お陰様で、無事に稼働いたしております。本当に感謝の気持ちです。
今回の内容に近いお話なのですが、ご教示をよろしくお願いします。 以下のような表があります。 A列に店舗名、B列に、種類、C列に種類細目、D・F・H・J・L列に日付、E・G・I・K・M列に都道府県が入っております。(表ではI列まで記載) A列は、B列のカンマの数だけコピーし、B・C列、D・F・H列、E・G・I列は、その挿入した欄に各々値でコピーしたいのです。 行数は、約12,000行です。 何度もすいません。何卒ご教示くださいますようお願い申し上げます。
A B C D E F G H I A店 やさい キャベツ 5/1 北海道 A店,B店 やさい、くだもの にら、りんご 5/2 青森 5/2 秋田 B店,C店 パン、お肉 アンパン、豚 5/2 神奈川 5/2 岐阜 A店,B店、C店 やさい、さかな、お肉 レタス、ブリ、鳥 5/3 埼玉 5/3 東京 5/4 群馬
A B C D E A店 やさい キャベツ 5/1 北海道 A店,B店 やさい にら 5/2 青森 A店,B店 くだもの りんご 5/2 秋田 B店,C店 パン アンパン 5/2 神奈川 B店,C店 お肉 豚 5/2 岐阜 A店,B店、C店 やさい レタス 5/3 埼玉 A店,B店、C店 さかな ブリ 5/3 東京 A店,B店、C店 お肉 鳥 5/4 群馬
（aki） 2016/07/31(日) 18:15
（マナ） 2016/07/31(日) 18:33
こんばんわ。
確認したい事が3点あります。
1,B列とC列の[、]の数は必ず同じになるんですか？ もし違う場合はどういう表現にするんですか？ D列からI列に関しても同じで、[、]の数と同じだけの列数になるんですか？
2,またB列[文字1、文字2、文字3、文字4、文字5]の順番と、 C列[文字6、文字7、文字8、文字9.文字10]、 [D・E列、F・G列、H・I列、J・K列、L・M列]の並び順は同じで良いんですか？
3,元データの列数は、今後M列以上になる事はあり得ませんか？
修正に関してですが、
配列領域の確保の部分は、列で[、]の数が異なるのでしたら、マナさんのか私のtest2のような予め十分に大きい領域を確保しておくと言うのが良いですね。
配列へのデータ格納部分は誰のを使っても正直全く同じなので、修正方法も同じになるんですが、 (変数名が違うのとループの方法がFor iかFor Eact使ってるかだけの違いだけです) C列の文字分割転記に関しては、B列のと同じように行えば良いだけですが、D列からM列の部分は配列に慣れていないと難しいかも知れませんね。
配列案なら誰のコードでも修正方法は同じになると思うので、今現在使用されているコードと(変数名などが若干違うので) 何処までが理解されていて、何が分からないかを提示されてはどうでしょうか。
（sy） 2016/07/31(日) 19:56
現在、最初のテーマで、akiさんが採用した方式によるコード、これを元に回答側から回答案を提示したほうが わかりやすいと思います。
皆さんからいろいろな方式の提示があったわけですが、
>>お陰様で、無事に稼働いたしております
ということですから、まずは、そのコードをアップして、この方式でやっているんだと示されたらよろしいかと。
（β） 2016/07/31(日) 20:01
回答とは関係のないコメントですのでスルーいただいてもOKです。
提示のレイアウトは、何か、取引の実績をある単位で入力したものでしょうかね。
で、そうだとして眺めた場合
B列に やさい、くだもの、パン、お肉 というものがあったとします。 これは C列の たとえば かぼちゃ、りんご、メロンパン、合い挽き といったものと対になるわけですよね。
その組み合わせと順番を間違えずに B列とC列に入力する。 う〜ん・・・結構、入力間違いが発生しそうですね。
たとえば B列は入力せず、レイアウトでいえば C列のデータだけを入力する。 別途、かぼちゃ は やさい、りんご は くだもの といった紐付けテーブルを持っておいて、B列情報は そこから抽出する。マクロ処理にしろ関数処理にしろ、それがデータ入力仕様の原則だと思いますよ。
（β） 2016/07/31(日) 20:25
＞1,B列とC列の[、]の数は必ず同じになるんですか？ はい、システムからCSVで吐き出されるため、必ず数は同じです。
＞2,またB列[文字1、文字2、文字3、文字4、文字5]の順番と、 C列[文字6、文字7、文字8、文字9.文字10]、 [D・E列、F・G列、H・I列、J・K列、L・M列]の並び順は同じで良いんですか？ はい、同じ並び順で大丈夫です。
＞ 3,元データの列数は、今後M列以上になる事はあり得ませんか？ はい、ございません。1万件行かないぐらいの数字ですので、大目にしております。
＞ 配列案なら誰のコードでも修正方法は同じになると思うので、今現在使用されているコードと(変数名などが若干違うので) 何処までが理解されていて、何が分からないかを提示されてはどうでしょうか。 申し訳ありません。おっしゃる通りです。しかしながら、全く分からないのが正直なところです。
（aki） 2016/07/31(日) 21:15
どのコードを踏まえておられるのかが不明ですので、とりあえず、私がアップした Sample2 を踏まえて書きました。
Sub Sample3()
Dim shF As Worksheet
Dim shT As Worksheet
Dim c As Range
Dim v As Variant
Dim wB As Variant
Dim wC As Variant
Dim n As Long
Dim a As String
Dim x As Long
Dim i As Long
Set shF = Sheets("Sheet1") '元シート
Set shT = Sheets("Sheet2") '展開シート
'転記シートタイトル行以外をクリア
shT.Range("A1", shT.UsedRange).Offset(1).ClearContents
With shF.Range("B2", shF.Range("B" & Rows.Count).End(xlUp))
a = .Address
'展開データの総行数
n = .Rows.Count + Evaluate("SUM(LEN(" & a & ")-LEN(SUBSTITUTE(" & a & ",""、"","""")))")
ReDim v(1 To n, 1 To 5) '展開データ格納配列
For Each c In .Cells
wB = Split(c.Value, "、")
wC = Split(c.Offset(, 1).Value, "、")
If UBound(wC) <> UBound(wB) Then
MsgBox c.Row & "行目のB列、C列が不整合のため処理をスキップします"
Else
For i = LBound(wB) To UBound(wB)
x = x + 1
v(x, 1) = c.EntireRow.Range("A1").Value
v(x, 2) = wB(i)
v(x, 3) = wC(i)
v(x, 4) = c.EntireRow.Range("D1").Offset(, i * 2).Value
v(x, 5) = c.EntireRow.Range("D1").Offset(, i * 2 + 1).Value
Next
End If
Next
End With
shT.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
shT.Select
End Sub
（β） 2016/07/31(日) 21:33
To βさん
何かβさんのコードでエラーが。
v(x, 1) = c.EntireRow.Range("A1").Value
の所で「実行時エラー9 インデックスが有効範囲にありません。」になりますね？
test3を修正したコードです。 列数がI列・M列どちらでも対応していますが、[、]の数とD列以降の列数の不一致のエラー処理はしていません。
Sub test4()
Const sh1Name As String = "Sheet1"
Const sh2Name As String = "Sheet2"
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim ary1, ary2, r
Dim rowNo As Long
Dim buf() As String
Dim ia As Long
Dim ib As Long
Dim j As Integer
'変数に格納
Set sh1 = Sheets(sh1Name)
Set sh2 = Sheets(sh2Name)
r = sh1.Range("A2").CurrentRegion.Columns(2).Value
rowNo = UBound(Split(Join(WorksheetFunction.Transpose(r), "、"), "、")) + 1
r = sh1.Range("A2").CurrentRegion.Value
ReDim buf(1 To rowNo, 1 To 5)
'変数内で書き込み
For ia = 1 To UBound(r, 1)
ary1 = Split(r(ia, 2), "、")
ary2 = Split(r(ia, 3), "、")
If UBound(ary1) = UBound(ary2) Then
For j = 0 To UBound(ary1)
ib = ib + 1
buf(ib, 1) = r(ia, 1)
buf(ib, 2) = ary1(j)
buf(ib, 3) = ary2(j)
buf(ib, 4) = r(ia, j * 2 + 4)
buf(ib, 5) = r(ia, j * 2 + 5)
Next j
End If
Next ia
'シートに書き出し
sh2.Range("A2:E" & Rows.Count).ClearContents
sh2.Range("A2").Resize(rowNo, 5).Value = buf
End Sub
（sy） 2016/07/31(日) 23:22
>>何かβさんのコードでエラーが。
こちらで、13000行ぐらいのテストデータを作成して、問題なく処理できていますが、B列文字列の状態によって
n = .Rows.Count + Evaluate("SUM(LEN(" & a & ")-LEN(SUBSTITUTE(" & a & ",""、"","""")))")
これで意図した行数の取得ができないケースがあるのでしょうか・・・
皆さんがやっておられるように
ReDim v(1 To n, 1 To 5) '展開データ格納配列
を
ReDim v(1 To Rows.Count, 1 To 5) '展開データ格納配列
に変更し
shT.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
を
shT.Range("A2").Resize(x, UBound(v, 2)).Value = v
に変更したほうが安全かもしれませんね。
（β） 2016/08/01(月) 00:08
To βさん
エラーの原因が分かりました。
n = .Rows.Count + Evaluate("SUM(LEN(" & a & ")-LEN(SUBSTITUTE(" & a & ",""、"","""")))")
の所で、要素数が正しく取得出来ていないみたいです。
shF がアクティブになっていない時は取得できないようですね。
a = .Address(External:=True)
にすればエラーは出ないですね。
（sy） 2016/08/01(月) 00:10
To sy さん
わぁ！ 考えてみれば当たり前でした。（汗、汗・・お恥ずかしい） デバッグ、ありがとうございました。
To aki さん
もし、β の Sample3 を試す場合は、
sy さんご指摘のように
a = .Address を a = .Address(External:=True)
あるいは
n = .Rows.Count + Evaluate("SUM(LEN(" & a & ")-LEN(SUBSTITUTE(" & a & ",""、"","""")))")
を
n = .Rows.Count + shF.Evaluate("SUM(LEN(" & a & ")-LEN(SUBSTITUTE(" & a & ",""、"","""")))")
に変えて試してください。
（β） 2016/08/01(月) 06:35
コーディング有難う御座いました。感謝申し上げます。 Sample3のコードを、ご指摘いただきました内容で変更させて頂きました。 ばっちりです。本当に有難う御座います。
syさま
コーディング有難う御座いました。感謝申し上げます。
みなさまへ
本当にお付き合いを頂き有難う御座いました。 何時の日か、質問者から回答者になれるように努力します。 また勉強させて下さい。よろしくお願いします。
（aki） 2016/08/01(月) 20:41
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.