[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数シートの色のついた行を別シートへ順番に転記したいです』（オクトパス）
Excel2003、WindowsＸＰを使用しております。
つい先日ＶＢＡを始めたばかりの超初心者なのですが、
業務命令で以下のようなＥｘｃｅｌを作らなければならなくなりました。
１つのブックに全部で１３枚のシートがあります。（ひと月に１枚＋転記用シートです）
各シートの１行目はそれぞれ４月、５月、６月、、、と月が入力してあり、
２行目は１２枚全て同じ項目行です。
行は各シート共に３行目〜２００行目まであり、
列はＡ列〜Ｘ列まで使用しております。
このうち、３行目〜２００行目で、かつＧ列〜Ｐ列のセルに色がついているものがあれば
１行目と２行目と色のついている行を転記用シートへ転記し、
セルに色がついている行が全くなければその月のシートは１行目も２行目も
全くコピーしないまま、翌月のシートの処理へとすすめていきたいのですが、
なかなかうまくいかないまま、時間だけが過ぎ去っていきます。。。
どなたかお知恵を拝借できればと助かります。
どうぞよろしくお願い致します。
一例 (アップ後、ckCol 規定を修正）
Sub Sample()
Const stRow As Long = 3
Const edRow As Long = 200
Const ckCol As String = "G:P"
Dim shFrom As Worksheet
Dim shTo As Worksheet
Dim a As Range
Dim r As Range
Dim myColor As Variant
Dim flag As Boolean
Dim done As Boolean
Dim z As Long
Application.ScreenUpdating = False
Set shTo = Sheets("転記用シート")
shTo.UsedRange.Clear
For Each shFrom In Worksheets
If Not shFrom Is shTo Then
Set a = Nothing
For Each r In shFrom.Rows(stRow & ":" & edRow)
flag = False
myColor = r.Columns(ckCol).Interior.ColorIndex
If IsNull(myColor) Then
flag = True
Else
If myColor <> xlNone Then flag = True
End If
If flag Then
If a Is Nothing Then
Set a = r
Else
Set a = Union(a, r)
End If
End If
Next
If Not a Is Nothing Then
Set a = Union(a, shFrom.Rows("1:2"))
If Not done Then
z = 1
done = True
Else
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 1
End If
a.Copy shTo.Range("A" & z)
End If
End If
Next
shTo.Select
Application.ScreenUpdating = True
MsgBox "転記終了"
End Sub
(ぶらっと)
ぷらっと様、どうもありがとうございます！！
早速試してみたのですが、
a.Copy shTo.Range("A" & z)
の部分が黄色くなり、処理を実行することができません。。。
また、情けないことに一行目に書いて下さった
(アップ後、ckCol 規定を修正）の意味が理解できません。
何か修正をしないと処理実行できないのでしょうか？
何度もすみませんが、またお知恵をお貸し下さると助かります。
どうぞよろしくお願い致します。
（オクトパス）
まず、(アップ後、ckCol 規定を修正） 混乱させたかな？ コードをアップしたんだけど、テスト用に範囲を絞ったコードにしていて それを、そのままアップしちゃったので、編集で呼び出してコードの一部を直して再掲載したよという意味。
で、
>a.Copy shTo.Range("A" & z)
>の部分が黄色くなり、処理を実行することができません。。。
う〜ん？？？ その時、どんなメッセージが出た？
(ぶらっと)
ぷらっと様
再度のご返信、どうもありがとうございます。
コードアップの件、理解いたしました。初歩的な質問ですみません・・・
黄色くなった時のメッセージは
実行時エラー'-2147221080(800401a8)':
オードメーションエラーです。
と出てきます。
シート１（４月）〜シート１２（３月）まで、
順番に「転記用シート」に転記していきたいのですが、
私がそれを申し伝え忘れていたようです。
重ね重ね申し訳ありません。
また、Ａ列〜Ｋ列までは場合によりＡ７セル〜Ａ９セルまで結合されている時もあったり、
Ｃ１０セル〜Ｃ１１セルが結合されている時もあったりするのですが、
それがエラーと関係があるのでしょうか？
説明不足で本当に申し訳ありません。
どうぞよろしくお願い致します。
（オクトパス）
ぷらっと様
たびたび申し訳ありません。オクトパスです。
今、再度処理実行してみたところ
実行時エラー'1004'
結合されたセルの一部を変更することはできません。
というメッセージが出てきました。
何回トライしてみてもこのメッセージが出て黄色くなっております。
お手数ですがどうぞよろしくお願い致します。
（オクトパス）
>結合されたセルの一部を変更することはできません。
なんとなく、そんな気がしていた。 元シートの行の中に、列結合されているところがあるんだね？ (行結合はないね？） ちょっと、手当てして出来上がり次第アップするね。
(ぶらっと)
オクトパスです。
早速のご返信、本当にありがとうございます。
ぷらっと様のおっしゃる通り、列結合されているところがありますが、
行結合はございません。
どうかよろしくお願い致します。
（オクトパス）
>列結合されているところがありますが、行結合はございません。
>Ａ７セル〜Ａ９セルまで結合されている時もあったり、Ｃ１０セル〜Ｃ１１セルが結合されている時もあったりするのですが、
いやいや、A7〜A9 なので、これは行結合（行が結合されている）
ところで、このケースで G8(結合されていないセル）に色がついていたとする。 7行目と9行目には色はついていない。 この場合は、どういう転記イメージ？
(ぶらっと)
ぷらっと様
大変失礼致しました。
行結合がされておりますが、列結合はございません、の誤りでした。
G8（結合されていないセル）に色がついていた場合、
８行目だけを転記用シートに転記したく考えております。
また、例えば６〜７行目において
K6〜K7が結合されていて色もついている、かつM6だけ色がついている場合は
６〜７行目を転記用シートに転記して、
K6〜K7が結合されているが色がついておらず、M6だけ色がついている場合は
６行目だけ転記したいのです。
初心者なのにあつかましいお願いで本当に申し訳ありません。
今、最初に送っていただいたコードを必死に勉強しております。。。
（オクトパス）
はい、ちょっと悩んでみる。
>今、最初に送っていただいたコードを必死に勉強しております。。。
とりあえず、今のブックを別名で保存して、その別名のブックのシートの結合をすべて解除して アップ済みのコードを動かしてみると、何をやっているか、コードを追いかけやすいかもしれない。
(ぶらっと)
かなり、ヘビーかも・・・
>G8（結合されていないセル）に色がついていた場合、 >８行目だけを転記用シートに転記したく考えております。
この８行目のＡ列は A7:A9が結合されているわけで、そうすると、セルの値としては A7 の値が表に見えているね。で、A8,A9 は空白となっているということは認識してるね？ でも、要望としては、その行が属しているA列のセルの結合セルとしての最初の行の値を コピーしたいんだろうね？（空白じゃいやだよね？）
そうすると、いったい、どこが結合されているか、しらみつぶしに調べていく必要がある。
この場合、A列は空白でいいです と、やさしい（？）言葉を頂ければ軽くなるんだけどね？ (それでも、ややこしいよ）
(ぶらっと)
ぷらっと様
オクトパスです。
ご返信下さりどうもありがとうございます。
セルが結合されていると尚更ややこしくなってしまうのですね。
何度も申し訳ありませんが、このようなことは果たしてＶＢＡで可能なのでしょうか？
例えば６〜７行目において
K6〜K7が結合されていて色がついておらず、かつM6だけ色がついている場合も
６〜７行目を転記用シートに転記する、
というように変えるとＶＢＡで処理できるものなのでしょうか？
（できることならＡ列を空白にしない方向で実行を希望しております。。。ごめんなさい）
たびたびのご尽力、本当に感謝しております。
どうぞよろしくお願い致します。
（オクトパス）
とりあえず以下で試してみて。 (ちょっと、インチキをした。転記結果はすべての結合がはずれた形になっている）
Sub Sample2()
Const stRow As Long = 3
Const edRow As Long = 200
Const ckCol As String = "G:P"
Dim sh As Worksheet
Dim shfrom As Worksheet
Dim shTo As Worksheet
Dim a As Range
Dim c As Range
Dim r As Range
Dim myColor As Variant
Dim flag As Boolean
Dim done As Boolean
Dim z As Long
Application.ScreenUpdating = False
Set shTo = Sheets("転記用シート")
shTo.UsedRange.Clear
Sheets.Add After:=shTo '作業用ワークシート
Set shfrom = ActiveSheet
For Each sh In Worksheets
If Not sh Is shTo And Not sh Is shfrom Then
'シートを作業シートにコピーして結合解除等々の処理を行い、
'その作業用シートをコピー元のシートにする。
shfrom.Cells.Clear
sh.Cells.Copy shfrom.Range("A1")
For Each c In shfrom.UsedRange
If c.MergeCells Then
Set r = c.MergeArea
c.MergeCells = False
r.Value = r(1).Value
End If
Next
'===================== 作業用シート作成完了
Set a = Nothing
For Each r In shfrom.Rows(stRow & ":" & edRow)
flag = False
myColor = r.Columns(ckCol).Interior.ColorIndex
If IsNull(myColor) Then
flag = True
Else
If myColor <> xlNone Then flag = True
End If
If flag Then
If a Is Nothing Then
Set a = r
Else
Set a = Union(a, r)
End If
End If
Next
If Not a Is Nothing Then
Set a = Union(a, shfrom.Rows("1:2"))
If Not done Then
z = 1
done = True
Else
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 1
End If
a.Copy shTo.Range("A" & z)
End If
End If
Next
Application.DisplayAlerts = False
shfrom.Delete
Application.DisplayAlerts = True
shTo.Select
Application.ScreenUpdating = True
MsgBox "転記終了"
End Sub
(ぶらっと)
↑ これは
>K6〜K7が結合されていて色がついておらず、かつM6だけ色がついている場合も >６〜７行目を転記用シートに転記する、
これは対応していないバージョン。このケースだと、6行目だけが取り出される。
追記）
たとえば
>K6〜K7が結合されていて色がついておらず、かつM6だけ色がついている場合
この状態で、さらに、O4〜O6が結合されていた場合、M6から見ると K列としては 6〜7行目だけど、O列としては 4〜6行目になる。 そうするとコピー対象は、4〜7行目？？？ で、さらに、J列が J3〜J100 まで結合されていたとすると・・・・
このように、何が何だか分からなくなるねぇ。ロジックとしては。 何か決め事を作ることができるなら対応の方法もあるけどね。 色がついていたセルの行のA列から見ていって、最初に結合セルがあらわれる列の行結合状態で判断するとか。
追記の追記）まぁ、すべての列の結合状態を調べて、関連行をすべて転記するということもできないことはないけど それより、上記のケースなら、M6だけじゃなくとM7にも色を付けてもらうということで妥協したいなぁ・
さらに追記）どういう場所に色を付けるのか、実際の業務というか作業の基準がわからないんだけど 上記の場合なら M6 に色をつけるのではなく結合されている K6〜K7 に色を付けるという 運用ルールってのは無理なのかな？
(ぶらっと)
↑ と、いろいろ「ごたく」を述べたけど、考え直して。 たぶん以下で、要件はすべて満足するんじゃないかと。 転記先には元シートのセルの結合状況もすべて継承。
Sub Sample3()
Const stRow As Long = 3
Const edRow As Long = 200
Const ckCol As String = "G:P"
Const allCol As String = "A:X"
Dim shFrom As Worksheet
Dim shTo As Worksheet
Dim a As Range
Dim r As Range
Dim myColor As Variant
Dim flag As Boolean
Dim done As Boolean
Dim z As Long
Dim c As Range
Dim rx As Range
Application.ScreenUpdating = False
Set shTo = Sheets("転記用シート")
shTo.UsedRange.Clear
For Each shFrom In Worksheets
If Not shFrom Is shTo Then
Set a = Nothing
For Each r In shFrom.Rows(stRow & ":" & edRow)
flag = False
myColor = r.Columns(ckCol).Interior.ColorIndex
If IsNull(myColor) Then
flag = True
Else
If myColor <> xlNone Then flag = True
End If
If flag Then
Set rx = r
For Each c In r.Columns(allCol).Cells
If c.MergeCells Then
Set rx = Union(rx, c.MergeArea.EntireRow)
End If
Next
If a Is Nothing Then
Set a = rx
Else
Set a = Union(a, rx)
End If
End If
Next
If Not a Is Nothing Then
Set a = Union(a, shFrom.Rows("1:2"))
If Not done Then
z = 1
done = True
Else
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 1
End If
a.Copy shTo.Range("A" & z)
End If
End If
Next
shTo.Select
Application.ScreenUpdating = True
MsgBox "転記終了"
End Sub
(ぶらっと)
ぷらっと様
オクトパスです。
ご返信下さり、本当に感謝しております。
いただいたマクロを実行してみましたところ、まさに希望したとおりの結果が出てきて
感無量です！
本当にありがとうございました。
また、今後の勉強として幾つか教えていただきたいのですが、
もしK6〜K7が結合されていて色がついておらず、かつM6だけ色がついている場合は
６行目だけを転記用シートに転記する
にはマクロのどの部分を変更すればよいのでしょうか？
ちなみにＡ７〜Ａ９列目が結合されていれば、
Ｂ７〜Ｂ９、Ｃ７〜Ｃ９、Ｄ７〜Ｄ９・・・Ｋ７〜Ｋ９まで必ず結合されております。
また、結合行同士がかぶることはなく、
Ｂ７〜Ｂ９が結合されていれば、７行目は６行目と結合されるセルもなく、
９行目が１０行目と結合されるセルもありません。
また、Ｌ列〜Ｘ列までは結合セルはありません。
おそらく２回目に教えていただいたマクロを実行し、
解除されたセルを再度結合させればよいのかなと想像しているのですが・・・
お手数ですが勉強のために教えていただければ嬉しいです。
どうぞよろしくお願い致します。
（オクトパス）
>もしK6〜K7が結合されていて色がついておらず、かつM6だけ色がついている場合は >６行目だけを転記用シートに転記する
オクトパスさん推察の通り、Sample2を実行すればいいと思う。 一度、やってみてくれえるかな？
なお、Sample2で結合解除しているのは元シートをコピーした作業用シート。 元シートに対しては変更していないので安心して。
(ぶらっと）
ぶらっと様
オクトパスです。
ぶらっと様、ご返信本当にありがとうございます。
ぶらっと様のおっしゃる通り、Sample2を実行してみたのですが、
そこからうまく解除されたセルを再び結合させる記述方法が分かりません。
Sample2のマクロのどこをどう変更させればよいのでしょうか？
また、転記用シートに転記する際に、前に転記したデータから2行あけて
転記するにはどこを変更すればよろしいでしょうか？
質問ばかりで申し訳ありません。
どうぞよろしくお願い致します。
（オクトパス）
>Sample2を実行してみたのですが、 >そこからうまく解除されたセルを再び結合させる記述方法が分かりません
あぁ、結合復活というのが、転記先で再結合という意味だったんだね。 これは、ここを、こう改訂して・・・というレベルのものではなく、全く異なるコードを書く必要がある。 しかも、できるかどうか、やってみないと・・・
というか、転記されたものの、どこを再結合するんだろうか？
たとえば３行結合されていたものの中で１行だけ転記対象という場合は、再結合は不要だよね。 １行しか転記していないのだから。 たまたま３行結合されていたものの中で２行が転記対象だったら、その２行を再結合するという意味？ K6〜K8 が結合セルで色無し。M6とM8が色つきだった場合、6行目と、8行目をコピーするわけだけど そのコピーされたK列の２行（元のK6とK8）を結合？
>また、転記用シートに転記する際に、前に転記したデータから2行あけて >転記するにはどこを変更すればよろしいでしょうか？
これは簡単。Sample2、Sample3 ともに
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 1 ↓ z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 3
(ぶらっと)
ぶらっと様
オクトパスです。
おかげさまで２行ずつあけて転記することができました！！
どうもありがとうございます。
また、結合セルに戻したい件ですが、
ぶらっと様のおっしゃる通り、
>たまたま３行結合されていたものの中で２行が転記対象だったら、 その２行を再結合させたいのです。
>K6〜K8 が結合セルで色無し。M6とM8が色つきだった場合、 6行目と、8行目をコピーするわけだけどそのコピーされたK列の ２行（元のK6とK8）だけでなく、Ａ列〜Ｋ列まで同様に結合させたく思っております。
Ａ列で結合セルがあった場合、Ｂ列〜Ｋ列まで、
Ａ列と同じ結合セルにしたいのです。
例えば転記の結果、Ａ７とＡ８が同じ値ならば結合させて
同様にＢ７とＢ８セルも結合、Ｃ７とＣ８セルも結合・・・
というようにＫ７とＫ８セルまで結合させたいのですが
これは可能なのでしょうか？
何度も申し訳ありません。
どうぞよろしくお願い致します。
（オクトパス）
本来なら、転記後の各セルが、その上のセル、下のセルと元シートで結合されていたかどうかで再設定判断をすべきだけど それを行うには、結構な仕掛けが必要（できないことはないけど）
なので、「簡易版」として
>ちなみにＡ７〜Ａ９列目が結合されていれば、 >Ｂ７〜Ｂ９、Ｃ７〜Ｃ９、Ｄ７〜Ｄ９・・・Ｋ７〜Ｋ９まで必ず結合されております。 >また、結合行同士がかぶることはなく、 >Ｂ７〜Ｂ９が結合されていれば、７行目は６行目と結合されるセルもなく、 >９行目が１０行目と結合されるセルもありません。 >また、Ｌ列〜Ｘ列までは結合セルはありません。
この条件を前提にして、かつ、結合されていたかどうかは、
>例えば転記の結果、Ａ７とＡ８が同じ値ならば結合(Ｂ列〜Ｋ列まで)
この判定方法で。
Sub Sample4()
Const stRow As Long = 3
Const edRow As Long = 200
Const ckCol As String = "G:P" '背景色チェック列領域
Const rmCol As String = "A:K" '転記後のセル再結合必要列領域
Dim sh As Worksheet
Dim shFrom As Worksheet
Dim shTo As Worksheet
Dim a As Range
Dim c As Range
Dim r As Range
Dim myColor As Variant
Dim flag As Boolean
Dim done As Boolean
Dim z As Long
Dim f As Long
Dim t As Long
Dim i As Long
Dim m As Range
Application.ScreenUpdating = False
Set shTo = Sheets("転記用シート")
shTo.UsedRange.Clear
Sheets.Add After:=shTo '作業用ワークシート
Set shFrom = ActiveSheet
For Each sh In Worksheets
If Not sh Is shTo And Not sh Is shFrom Then
'シートを作業シートにコピーして結合解除等々の処理を行い、
'その作業用シートをコピー元のシートにする。
shFrom.Cells.Clear
sh.Cells.Copy shFrom.Range("A1")
For Each c In shFrom.UsedRange
If c.MergeCells Then
Set r = c.MergeArea
c.MergeCells = False
r.Value = r(1).Value
End If
Next
'===================== 作業用シート作成完了
Set a = Nothing
For Each r In shFrom.Rows(stRow & ":" & edRow)
flag = False
myColor = r.Columns(ckCol).Interior.ColorIndex
If IsNull(myColor) Then
flag = True
Else
If myColor <> xlNone Then flag = True
End If
If flag Then
If a Is Nothing Then
Set a = r
Else
Set a = Union(a, r)
End If
End If
Next
If Not a Is Nothing Then
Set a = Union(a, shFrom.Rows("1:2"))
If Not done Then
z = 1
done = True
Else
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 3
End If
a.Copy shTo.Range("A" & z)
End If
End If
Next
Application.DisplayAlerts = False
shFrom.Delete
'==== セルの再結合処理 開始
f = 1
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 1 'データ最終行の次の行
For Each c In shTo.Rows("1:" & z).Columns(rmCol)(1).Cells
t = c.Row
If c.Value <> c.Offset(1).Value Then
If f <> t And WorksheetFunction.CountA(shTo.Rows(f)) > 0 Then
For Each m In shTo.Rows(f).Columns(rmCol).Cells
m.Resize(t - f + 1).MergeCells = True
Next
End If
f = t + 1
End If
Next
'==== セルの再結合処理 終了
Application.DisplayAlerts = True
shTo.Select
Application.ScreenUpdating = True
MsgBox "転記終了"
End Sub
(ぶらっと)
ぶらっと様
オクトパスです。
ご返信下さりありがとうございます。
Sample4のマクロを実行しましたところ、
解除されていたセルを再度結合させることができました！
どうもありがとうございます。
ただ、今後の勉強のためにチャレンジしてみたかった
もしK6〜K7が結合されていて色がついておらず、かつM6だけ色がついている場合は ６行目だけを転記用シートに転記する
とするには、一体どのようにしたらよいのでしょうか？
（Sample4マクロでは６行目と７行目が表示されるということは理解できました）
説明が下手でごめんなさい。
そして何度も本当に申し訳ありません。
どうぞお知恵をお貸し下さい。。。
（オクトパス）
えっ？？？ このケース、Sample4 では 6行目だけが転記されるけど？
>Sample4マクロでは６行目と７行目が表示されるということは理解できました
ほんとにそうなる？ こちらで、同じデータをつくって動かしたけど7行目は転記されないよ？ 7行目のどこか別のセルに色がついていない？
追記）それとも、たとえば 6行目が転記された。で、8行目以降の対象の行も転記された。 その8行目以降の行のA列が【たまたま】元のA6と同じ値だった。 簡易版条件として結合されていたかどうかの判定は、A列の値が同じかどうかで行っている。 なので、この場合は、もともとは結合されていなかったのに転記シートでは結合されてしまう。 現在の構えで、A列だけではなくA〜K列の値が完全に同じなら結合とみなすようにするのは簡単だけど でも、「たまたま、それらも同じ値」だったら、もう「簡易版」ロジックでは対応できない。 先にコメントしたように、オリジナルでは結合されていたかの仕掛け（コード的にも、かなり煩雑な仕掛け）が必要。
(ぶらっと)
ぶらっと様
オクトパスです。
ごめんなさい、K6〜K7に色がついてない場合はぶらっと様のおっしゃる通り
Sample4でうまくいきました！
私が伝え間違えておりました。
例えばK6〜K8に色がついているが、M列はM7セルにだけ色がついている場合に、
６行目と８行目を転記せずに７行目だけを転記したい場合は
どのような記述をすればよいのでしょうか？
と質問したかったのです。
（ごめんなさい、完全に私が混乱しておりました。。。）
どうかよろしくお願い致します。。。
（オクトパス）
もともとの大前提で
>Ｇ列〜Ｐ列のセルに色がついているものがあれば
こういうことだったよね。
>例えばK6〜K8に色がついているが、M列はM7セルにだけ色がついている場合
この条件は、上の大前提を踏まえると、G〜Pの中の K列（K6:K8)に色がついているのだから M列がどうあれ（仮にM7が色なしでも）6〜8行目は転記対象ということになるよね？
変に近視眼的（？）対処をすると、G〜PのなかのK6:K8に色がついているのに、「転記されない！！不具合だ！！」 こういうことになってしまわない？
そちらの要件を、「仕様」として、言葉で記述できるかなぁ？ 要件が明確になれば「いかようにも」対応可能だけど、要件記述不可能ということになるとコードもかけないので。
追記）どういった項目に色を付けるのか、その具体的な運用が見えないんだけど、たとえば Ｇ〜Ｐ列の範囲であっても「結合セル」の色は、色とみなさないという要件にするなら これはこれで、「仕様」として成り立つけど？
(ぶらっと)
ぶらっと様
オクトパスです。
ご返信下さりどうもありがとうございます。
分かりにくいかと思いますが、
私の要件（使用しているシートの仕様）を記述させていただきます。
まず、
Ａ１セルには「○月 受付分」と入力されております。
２行目にはＡ列〜Ｘ列までのタイトルを入力。（会社名、受付日、曜日 など）
３行目〜２００行目までの
Ａ列には注文を受けた会社名（○○株式会社 など）
Ｂ列には注文受付日（4/9 など）
Ｃ列には曜日（水 など）
Ｄ列には受付時間（10：25 など）
Ｅ列には先方の担当者名（佐藤 など）
Ｆ列には先方の責任者名（山田 など）
Ｇ列には金額（48,000 など）
Ｈ列には会社コード（Ｚ1633719 など）
Ｉ列には先方からの書類Ａの提出状況（○、提出待ち など）
Ｊ列には先方からの書類Ｂの提出状況（○、提出待ち など）
Ｋ列には先方からの書類Ｃの提出状況（○、提出待ち など）
Ｌ列にはＡ列に入力された会社の配送希望先の会社名（△△商店、□□酒店 など）
Ｍ列にはＬ列の会社からの書類Ｄの提出状況（○、× など）
Ｎ列にはＬ列の会社からの書類Ｅの提出状況（○、× など）
Ｏ列にはＬ列の会社からの書類Ｆの提出状況（○、× など）
Ｐ列にはＬ列の会社からの書類Ｇの提出状況（○、× など）
Ｑ列には受け付けた当社の担当者名（斉藤、武田 など）
Ｒ列〜Ｘ列まではそれぞれ私の部の上司の使用欄
となっております。
よって、例えば配送先を４ヶ所希望している会社（Ａ列に入力された会社です）
から注文を受けた場合、
Ａ列は４行分をセル結合し、必然的にＢ列〜Ｋ列までもＡ列と同様にセル結合させることになります。（現在はご存知のとおり手動で結合させています。。。）
配送希望先が４ヶ所なので、Ｌ列は結合させずに各行４ヶ所の配送先を入力し、
Ｍ列〜Ｘ列もＬ列に入力した会社とのやりとり状況を入力するため、
セルを結合させません。
そして、Ｇ列の金額欄〜Ｐ列の書類Ｇの提出状況欄までで
例えば未提出の状況の時などにセルに色をつけております。
例を申し上げますと
配送希望先を４ヶ所希望している会社から受注がきたので、
23行目に入力する場合、
Ａ23セル〜Ａ26セルを結合して会社名をＡ23セルに入力、
以降Ｋ列まで各列同様に４行分のセルを結合させ、
Ａ23セルに入力した会社と当社とのやりとり状況を入力。
Ｌ23セル〜Ｌ26セルは結合させずに各行に４社の会社名を入力、
以降Ｘ列まで結合させずにＬ列の会社とのやりとり状況を入力。
23行目〜26行目までについて
Ｍ24セルとＯ25セルだけに色がついている場合は
あくまでもＬ23セルとＬ26セルの会社とは何の問題もなく、
セルに色がついているわけでもないので、
23行目と26行目は転記シートに転記せずに、24行目と25行目だけを転記したいのです。
ぶらっと様、長い記述で申し訳ありません。。。
流れとしては、
４行結合されたＡ23セル〜Ａ26セルがある場合、
●Ｇ〜Ｋ列のどこかに色がついていてＬ列〜Ｐ列に色がついていない場合→23行〜26行の４行を転記
●Ｇ〜Ｋ列のどこかに色がついていてＭ24セルとＯ25セルに色がついてる場合→24行目と25行目を転記
●Ｇ〜Ｋ列のどこにも色がついていないがＭ24セルとＯ25セルに色がついている場合→この場合も24行目と25行目を転記
したいのです。
おそらくＡ列のセルの値が同じならば結合し、
それと同時にＢ列〜Ｋ列までも同様にセル結合させる。
また、転記の優先順位としては
Ｌ列〜Ｐ列の色つきセルを探して、色つきセルがあればその行を必ず転記し、
なければＧ列〜Ｋ列の色つきセルを探して色つきセルがあればその行を転記する。
という流れなのかな？と思われます。
（あくまでもど素人な私の考え方でございます。。。）
こんなかんじで伝わりますでしょうか・・・・？
また、願わくば
Excelの使用者が各月のシートに入力すべきところ、
間違えて転記用シートを使用してしまわないようにするために、
ブックを閉じる時、或いは次回ブックを使用する時（開く時）のどちらかの際に
転記用シートを削除しておきたい、と上司に言われたのですが
そんなことは可能でしょうか？
（ブックを使用する時は各月分の12枚のシートだけ、という状況にしたいのです）
そうなるとマクロを実行する時に”転記用シート”という名前のシートを新たに追加する必要があるということですよね。。。？
もし追加するのであれば、転記用シートを一番右側に追加できればとても助かります。
また、上司に「万が一手元が狂って一度に２回マクロを実行してしまっても、
転記用シートには一番新しいデータだけを転記するようにしてね」と言われたのですが、これはややこしい話なのでしょうか？
何度も申し訳ありません。
何卒よろしくお願い致します。。。
（オクトパス）
詳細説明深謝。これで実際のシートの状況とその運用がが目に浮かぶようになったので随分考えやすくなった。 あわせて、「元のシートの結合状況を調べる大がかりな仕組み」と「蘊蓄」を述べていたけど、 あらためて説明してもらったことを踏まえると、これも、もっと簡単に処理できそうだということもわかった。
説明された要件に従って新しいコードを書き、できあがりしだいアップする。
なお、転記用シートについては、他に、以下のような運用が考えられる。 もし、以下のいずれかがよければ、それにしよう。
１．入力してしまうリスクを回避したいと言うことだけなら、転記用シートの全セルを保護（初期設定ではすでにそうなっている） その上でシート保護を掛けておけば入力そのものができない。 この場合、コードでは、何もしなくてすむ。（もちろん、マクロからシートに書き込むので、そこはできるようにするけど） ２．転記用シート１枚だけの「新規別ブック」として作成。これを操作者が名前をつけて保存してもいいし 自分で閉じてもいいし、元ブックが閉じられるときに、もし残っていれば、ここはマクロで自動的に閉じる。 （つまり、元ブックには、そもそも転記用シートが存在しない） ３．転記用シートは「非表示」シートにしておき、転記時に自動表示。ブックが保存される際には自動的に非表示に戻す。
(ぶらっと)
ぶらっと様
オクトパスです。
運用方法を3種類も考えて下さり、本当にどうもありがとうございます。
私が最初から詳しく説明をしておけばよかったですね。
お手間をとらせて申し訳ありませんでした。
運用方法につきましては、２番の運用方法でいけたらとても嬉しいです。
どうぞよろしくお願い致します。
（オクトパス）
それでは以下で。 Sample5を実行するタイミングで新規ブックが生成されて、そこに転記される。 何度も行ってもいいけど、そのたびに新規ブックが生成されるので、そこは留意してね。 （前回の処理結果に追加されるということはない）
Sub Sample5()
Const ckColA As String = "G:K" '背景色チェック列領域その１
Const ckColB As String = "L:P" '背景色チェック列領域その２
Const mgCol As String = "A:K" 'セル結合領域
Dim sh As Worksheet
Dim shTo As Worksheet
Dim r As Range
Dim done As Boolean
Dim z As Long
Dim m As Range
Dim DelR As Range
Dim svSIN As Long
Application.ScreenUpdating = False
'転記用ブックを生成（注 処理ごとに新規ブックとして生成される）
svSIN = Application.SheetsInNewWorkbook '現在の設定を保存
Application.SheetsInNewWorkbook = 1 '新規ブックのシート数を1枚にする
Set shTo = Workbooks.Add.Sheets(1)
Application.SheetsInNewWorkbook = svSIN '復元
'元ブックのシートをすべて転記シートにコピー
For Each sh In ThisWorkbook.Worksheets
If Not sh Is shTo Then
If done Then
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 3
Else
z = 1
End If
done = True
sh.UsedRange.Copy shTo.Cells(z, "A")
End If
Next
'転記用シート上での処理
Call ValueSet(shTo, mgCol) '結合セルの裏に隠れているセルにも値をセット
For Each r In shTo.UsedRange.Rows
If WorksheetFunction.CountA(r) > 0 Then '挿入された２行の空白行は残す
If r.Row = r.Columns(mgCol)(1).MergeArea.Row Then '結合セルなら、その最初の行のみで処理
z = r.Columns(mgCol)(1).MergeArea.Rows.Count '結合を含めた行数
If IsColor(r.Columns(ckColB).Resize(z)) Then 'L〜P列に色つきセルがあるか？
'この行範囲の中の色なしセル行のみ削除対象
For Each m In r.Resize(z)
If Not IsColor(m.Columns(ckColB)) Then Call ToBeDeleted(m, DelR)
Next
ElseIf Not IsColor(r.Columns(ckColA).Resize(z)) Then 'G〜K列に色つきセルがなければ？
'この行範囲がすべて削除対象
Call ToBeDeleted(r.Resize(z), DelR)
End If
End If
End If
Next
If Not DelR Is Nothing Then DelR.Delete
shTo.Parent.Saved = True '強制的に保存済みステータスにする
Application.ScreenUpdating = True
MsgBox "転記終了"
End Sub
Private Function IsColor(a As Range) As Boolean
Dim myColor As Variant
myColor = a.Interior.ColorIndex
If IsNull(myColor) Then
IsColor = True
Else
If myColor <> xlNone Then IsColor = True
End If
End Function
Private Sub ToBeDeleted(fR As Range, tR As Range)
If tR Is Nothing Then
Set tR = fR
Else
Set tR = Union(tR, fR)
End If
End Sub
Private Sub ValueSet(sh As Worksheet, cols As String)
Dim c As Range
Dim x As Long
Dim i As Long
Dim m As Range
Dim z As Long
With sh
x = .UsedRange.Cells(.UsedRange.Cells.Count).Column + 2 '作業列
For Each m In .UsedRange
z = m.Row
If m.MergeCells And m.MergeArea(1).Address = m.Address Then
.Cells(1, x).CurrentRegion.Clear
i = 0
For Each c In m.MergeArea
i = i + 1
.Cells(i, x).Value = m.MergeArea(1).Value
Next
.Cells(1, x).CurrentRegion.Copy
m.MergeArea.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Cells(1, x).CurrentRegion.Clear
End If
Next
End With
End Sub
(ぶらっと)
ぶらっと様
オクトパスです。
いただいたマクロを実行してみたのですが、
エラーもなく「転記終了」となるのですが、
転記先シートにうまく反映されません。。。
各シートの１行目〜２行目が転記されないのです。
また、今回は２枚目のシートと３枚目のシートに色つきの行がなかったため、
転記用シートには１枚目のシートを転記したあとに、
２行あけて４枚目のシートの転記となると思うのですが、
１枚目のシートの転記のあとにかなりの行があいてから
４枚目のシートが転記されております。
また、その他のシートとシートの転記の間も１行あいていたり
３行あいていたりとなっております。
きっと私がまだ何か伝え漏れていることがあるのでしょうか・・・？
（オクトパス）
元ブックの各シートが説明してもらった通りのレイアウトで作られているなら１、２行目も必ずコピーされる。 こちらでは、うまくいってるので。
１、２行目が空白行なら、そういうことはありうる。
よく見えないんだけど、たとえば
sh.UsedRange.Copy shTo.Cells(z, "A")
これを
sh.Range("A1", sh.UsedRange).Copy shTo.Cells(z, "A")
こうして実行するとどうなる？
追記） ↑ わゎわぁごめん！ これについてはバグ。 これまでのロジック（色のついている行を抽出）と正反対に、色のついていない行を削除するロジックにしていたので せっかくコピーした１，２行目が削除されてしまった。 （たまたま、こちらでテストしているデータでは１、２行目に色を付けていたというおそまつ。） 後程訂正版をアップするね。でも、 ↓ は、ロジックの問題ではないと思うんだけど？
で、間が２行じゃなく３行だったり４行だったりというのは、これも、よくわからないけど 元ブックのシートの内容をコピーしているわけだけど、そのコピーされたデータの最終行を取得する際に 空白に見えていてもスペースや、目に見えないゴミがセルにはいっていると、そこには値があると認識される。 元ブックの各シートの、ここが最終だと見えるところの下、１０行ぐらいを選んで削除してから実行するとどうなるかな？
(ぶらっと)
とりあえず、タイトル行が消えてしまうバグ対応版。
If WorksheetFunction.CountA(r) > 0 Then '挿入された２行の空白行は残す
これを
If IsDataLine(r) Then '挿入された２行の空白行とタイトル行は残す
で、以下のプロシジャを新規追加。
Private Function IsDataLine(r As Range) As Boolean
If r.Row > 2 Then
If WorksheetFunction.CountA(r) > 0 Then
If WorksheetFunction.CountA(r.Offset(-1)) > 0 Or _
WorksheetFunction.CountA(r.Offset(-2)) > 0 Then IsDataLine = True
End If
End If
End Function
(ぶらっと)
↑ まだ、バグがあるみたい。もうちょっと待ってね。 それと、２つめの件、連絡待ってます。
(ぶらっと)
連絡した Private Function IsDataLine(r As Range) As Boolean の中の
Or を And にして。（お粗末でござんした。ペコ）
(ぶらっと)
ぶらっと様
オクトパスです。
ぶらっと様のおっしゃる通り、最終行と思われる行から下の行をまとめて削除して
マクロを実行してみたところ、うまく反映させることができました！！！
感激です。
ですが、色がついている行がない場合のシートが転記される時に
１行目〜２行目が転記されてしまいます。
データがないので、転記用シートにも１行目〜２行目を転記させないようにしたいのですが、
これも私の伝え漏れだったかもしれません。本当にごめんなさい。
また、もし行の結合だけでなく、例えば列の結合がある場合、
マクロの記述を少し変えることで対応できるものなのでしょうか？
上司使用欄のうち、Ｒ列〜Ｗ列まで、場合によって行結合はないのですが
列結合が発生する場合がありました。
（私の知らない間に上司が自分の使いやすいように列を結合する、ということが今後出てきそうなのです）
質問ばかりで本当にすみません。。。
どうぞよろしくお願い致します。
（オクトパス）
>データがないので、転記用シートにも１行目〜２行目を転記させないようにしたいのですが、 >これも私の伝え漏れだったかもしれません。本当にごめんなさい。
うん、伝え漏れ。でも、いわれてみれば至極まっとうだね。 最初のほうの、元シートの抽出の 部分を以下のように。
'元ブックのシートをすべて転記シートにコピー
For Each sh In ThisWorkbook.Worksheets
If Not sh Is shTo Then
If IsColor(sh.Columns(ckColA)) Or IsColor(sh.Columns(ckColB)) Then '★追加
If done Then
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 3
Else
z = 1
End If
done = True
sh.UsedRange.Copy shTo.Cells(z, "A")
End If '★追加
End If
Next
>また、もし行の結合だけでなく、例えば列の結合がある場合、 >マクロの記述を少し変えることで対応できるものなのでしょうか？
もともと、それを想定していないので、少し変えてできるかどうかは、見てみないと。 それより、まず、横に結合したデータを作ってやってみると、結果はどうなるだろう？ もしかしたら、結果オーライかもしれないし。そのあたりは、そちらで、実際に確かめてみてほしいな。
追記）今、こちらのデータで、簡単な横結合をつくってやってみたら、結果オーライ。 だけど、実際に、どんなふうな横結合なのか、実際の結合状況がわからないので やはり、そちらで試してみてね。
追記の追記） あっ！！ Ｒ列〜Ｗ列！！ ここは結合状況をコードではチェックしていないところなので。 いずれにしても、そちらでやってみて、うまくいかない場合は、要件として整理追加して 的を絞って質問してくれたらうれしい。
追記の追記の追記) たぶん、大丈夫みたいだよ。
(ぶらっと)
↑ 上司欄の横連結は大丈夫だと思う。 ただし、
>場合によって行結合はないのですが 列結合が発生する場合がありました。
もし、上司欄のみならず、列結合に加えて行結合をしたら（つまり、複数列複数行のセル領域が結合） アップ済みのコードは、実行時エラーになることは留意しておいてね。
(ぶらっと)
でも、上司は何をするかわからない？ なので、アップ済みのコードのうち、Private Sub ValueSet(sh As Worksheet, cols As String) を 以下で入れ替えておく方が無難かな？
Private Sub ValueSet(sh As Worksheet, cols As String)
Dim c As Range
Dim x As Long
Dim m As Range
Dim z As Long
With sh
x = .UsedRange.Cells(.UsedRange.Cells.Count).Column + 2 '作業列
For Each m In .UsedRange
z = m.Row
If m.MergeCells And m.MergeArea(1).Address = m.Address Then
.Cells(1, x).CurrentRegion.Clear
.Cells(1, x).Resize(m.MergeArea.Rows.Count, m.MergeArea.Columns.Count).Value = m.MergeArea(1).Value
.Cells(1, x).CurrentRegion.Copy
m.MergeArea.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Cells(1, x).CurrentRegion.Clear
End If
Next
End With
End Sub
(ぶらっと)
ぶらっと様
オクトパスです。
伝え漏れの件、大変失礼致しました。ごめんなさい。
色つきセルがないシートが無事転記用シートに反映されなくなりました！
ありがとうございました。
また、列結合の件は、列結合セルを作らなければうまくいくのですが、
試しに列結合を作り、そのセルに色をつけて実行してみたところ、
マクロはエラーもなく実行されるのですが
転記用シートにうまく反映されません。。。
（とりあえず、列結合だけで、行結合をさせずに試してみました）
まだ伝え漏れがあるのでしょうか。。。
なんだかとても申し訳ないです。。。
（オクトパス）
ぶらっと様
たびたびすみません、オクトパスです。
私の勘違いでした。
無事すべてうまく反映させることができました！！
ぶらっと様、本当にどうもありがとうございました。
これを機に、少しずつですが頑張って勉強していこうと思います。
（私の独学、かなり大変そうです(^_^;)）
この先、またつまづいたら、これからもお世話になると思います。
どうぞよろしくお願い致します。
本当にどうもありがとうございました。
（オクトパス）
たびたびすみません。オクトパスです。
いただいたマクロを試してみたのですが、
データのない月の１行目〜２行目がやはり転記されてしまいます。
といいますのも、ためしに色つきセルがないデータの月の２行目、
すなわちタイトル行の一部のセル（例えばセルＪ2）に色をつけた場合のみ、
データがないのに１行目〜２行目が転記されてしまうのです。。。
記述の一部を変更すればよいのでしょうか？
どのように変更すればよいか、お手数ですが教えていただけますと幸いです。
たびたびの質問で本当に申し訳ありません。
どうぞよろしくお願い致します。
（オクトパス）
>記述の一部を変更すればよいのでしょうか？ >どのように変更すればよいか
う〜ん・・・・それがコードの仕様なので・・・
ちなみに、現行のロジックは
・色つきチェック列に関して（タイトル行も含めて）色がついていれば、シートとしてはコピー対象。 ・その上で、データ行は色がなければ消すけど、タイトル行は無条件に残す。
こうなっている。 なのでシートコピーの判定で手を抜かずに、色つき列のチェックからタイトル行を除けばいいんだけどね。
タイトル行には転記要否にかかわらず色がつくのなら、そこを回避するコードを後ほどアップするね。
(ぶらっと)
If IsColor(sh.Columns(ckColA)) Or IsColor(sh.Columns(ckColB)) Then '★追加
前に、こんなコードを追加してもらうように連絡したね。それを以下の２行にかえて試してみてくれる？
z = sh.UsedRange.Cells(sh.UsedRange.Cells.Count).Row If IsColor(sh.Columns(ckColA).Resize(z - 2).Offset(2)) Or IsColor(sh.Columns(ckColB).Resize(z - 2).Offset(2)) Then
(ぶらっと)
オクトパスです。
'★追加のマクロ１行を上記の２行に変えて実行してみたのですが、
実行時エラー'1004'
アプリケーション定義またはオブジェクト定義のエラーです。
というエラーが出て、変更した２行のうち、２行目が黄色くなってしまいます。。。
何度も申し訳ありません。
ご指導下さいますよう、どうぞよろしくお願い致します。
（オクトパス）
その黄色くなったコードの z にマウスを当てると浮かび上がる値は？ まさか 2以下ということはないよねぇ？
ブック内にタイトル行だけのシートがあるのかな？ もしそうなら z = sh.UsedRange.Cells(sh.UsedRange.Cells.Count).Row の下に If z < 3 Then z = 3 を追加して逃げよう。
(ぶらっと)
黄色くなったコードのｚにマウスを当てると、
ｚ＝1 と出てきます。。。
また、ブック内にタイトル行だけのシートは存在しません。
各月ごとのシート１２枚だけです。。。
・・・かと思いきや、何もデータを入れていない
sheet1というシートが存在しておりました。（シート名はつけておりません）
今、ためしにSheet1を削除して当初の設定どおり１２枚のシートにしてから
実行してみたのですが、やはり黄色い行のままでして、
ｚにマウスを当てるとｚ＝１と出てきます。
またきっと私の伝え漏れなのかもしれませんが、
どうしても思いつかず。。。です。
何度も申し訳ありません。
どうぞよろしくお願い致します。
（オクトパス）
この場所で z が 1 ということは 空白シートか、あるいは1行だけのシートを相手にしていると言うこと。 「非表示」になっていて、そのようなシートはないだろうか？
いずれにしても、↑で連絡した
If z < 3 Then z = 3
これをいれて「逃げて欲しい」んだけど。
(ぶらっと)
非表示シートがない、あるいは、あっても、それはシート上に３行以上のデータがある、でもなおかつ エラーになるということなら連絡こう。
で、とりあえず、上で「逃げ」と表現したのは、コードを１行追加しただけで対応するための方策だから。 コードとしては以下のようになり、美しくない。
'元ブックのシートをすべて転記シートにコピー
For Each sh In ThisWorkbook.Worksheets
If Not sh Is shTo Then
z = sh.UsedRange.Cells(sh.UsedRange.Cells.Count).Row
If z < 3 Then z = 3 '★ 間に合わせの【逃げ】
If IsColor(sh.Columns(ckColA).Resize(z - 2).Offset(2)) Or IsColor(sh.Columns(ckColB).Resize(z - 2).Offset(2)) Then
If done Then
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 3
Else
z = 1
End If
done = True
sh.UsedRange.Copy shTo.Cells(z, "A")
End If
End If
Next
やはり、きちんと、以下のような構えにしておいたほうが、将来の条件追加等の対応時もやりやすいので いれかえておいてくれるかな？
'元ブックのシートをすべて転記シートにコピー
For Each sh In ThisWorkbook.Worksheets
If Not sh Is shTo Then
z = sh.UsedRange.Cells(sh.UsedRange.Cells.Count).Row
If z > 2 Then '★データ行がある場合のみ
If IsColor(sh.Columns(ckColA).Resize(z - 2).Offset(2)) Or IsColor(sh.Columns(ckColB).Resize(z - 2).Offset(2)) Then
If done Then
z = shTo.UsedRange.Cells(shTo.UsedRange.Cells.Count).Row + 3
Else
z = 1
End If
done = True
sh.UsedRange.Copy shTo.Cells(z, "A")
End If
End If '★
End If
Next
ーーーー
オクトパスです。
PCから離れた日々だったため、返信が遅くなり申し訳ありません。
いただいたマクロを実行してみたところ、無事うまくいきました！！
本当にどうもありがとうございました。
まだすべての記述を理解できておりませんが、一生懸命勉強していこうと思います。
ぶらっと様、本当にどうもありがとうございました。
（オクトパス）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.