Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9145 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【29022】データの埋め込み M 05/9/21(水) 20:57

【29036】Re:データの埋め込み M 05/9/22(木) 7:11

【29038】Re:データの埋め込み ichinose 05/9/22(木) 8:29

【29063】Re:データの埋め込み M 05/9/22(木) 21:25

【29064】Re:データの埋め込み ichinose 05/9/22(木) 22:39

【29083】Re:データの埋め込み M 05/9/23(金) 16:31

【29087】Re:データの埋め込み ichinose 05/9/23(金) 18:40

【29095】Re:データの埋め込み M 05/9/23(金) 21:59


	【29022】データの埋め込み

M - 05/9/21(水) 20:57 -


	引用なし

	パスワード

元の表があります。これは会計処理のソフトを使い、結果をエクセルに張り込んだものです。

元の表　　　　項目１　　　　項目２　　　　項目３　　　　項目４　　　　項目５
101　　　　AAA　　　　500　　　　300　　　　200　　　　500
102　　　　BBB　　　　400　　　　100　　　　50　　　　400
104　　　　DDD　　　　600　　　　0　　　　250　　　　600
105　　　　EEE　　　　150　　　　50　　　　0　　　　150
107　　　　FFF　　　　600　　　　0　　　　0　　　　600
109　　　　HHH　　　　180　　　　80　　　　50　　　　180

この元の表には、PPPのデータとGGGのデータに動きが無く,本来張り込まれるべきものですが、その動きが無く、張り込まれていません。
このように、項目１のデータは、動きのない時は表に出てきません。
それを、エクセル上で、この項目１を全て作り、データを差し込み（数字は項目２～４まで全て０の数字を入れ、表の集計して、結果として次の表のように仕上げたいのです。

仕上げ表　　　　項目１　　　　項目２　　　　項目３　　　　項目４　　　　項目５h
101　　　　AAA　　　　500　　　　300　　　　200　　　　500
102　　　　BBB　　　　400　　　　100　　　　50　　　　400
103　　　　PPP　　　　0　　　　0　　　　0　　　　0
104　　　　DDD　　　　600　　　　0　　　　250　　　　600
105　　　　EEE　　　　150　　　　50　　　　0　　　　150
107　　　　FFF　　　　600　　　　0　　　　0　　　　600
108　　　　GGG　　　　0　　　　0　　　　0　　　　0
109　　　　HHH　　　　180　　　　80　　　　50　　　　180

Sub 表の補完（）

Dim R As Range
Dim myR As Range
Set myR = Range(Cells(6, 2), Cells(35, 2))

For Each R In myR
If R.Value <> "PPP" Then
R.Value("BBB").Row.Select
Selection.Insert shift:=xlDown

End If
Next

End Sub

ここまでコードを書いたのですが、あとどのように展開したら
良いのか、アドバイスお願いします。


	【29036】Re:データの埋め込み

M - 05/9/22(木) 7:11 -


	引用なし

	パスワード

元の表があります。これを仕上げの表のようにしたいのです。

元の表　　項目１　　　項目２　　項目３　　項目４　　　項目５
101　　　　AAA　　　　500　　　　300　　　　200　　　　500
102　　　　BBB　　　　400　　　　100　　　　 50　　　　400
104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
105　　　　EEE　　　　150　　　　 50　　　　　0　　　　150
107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
109　　　　HHH　　　　180　　　　 80　　　　 50　　　　180

仕上げ表　項目１　　　項目２　　項目３　　　項目４　　項目５
101　　　　AAA　　　　500　　　　300　　　　200　　　　500
102　　　　BBB　　　　400　　　　100　　　　50　　　　400
103　　　　PPP　　　　　0　　　　　0　　　　0　　　　　0
104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
105　　　　EEE　　　　150　　　　50　　　　　0　　　　150
107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
108　　　　GGG　　　　　0　　　　　0　　　　　0　　　　　0
109　　　　HHH　　　　180　　　　80　　　　50　　　　180

何とかマクロで処理したくコードを書きましたが、もっとシンプルに
書く方法は無いでしょうか。このサンプル以上に挿入行が増えるものですから
ｼﾝﾌﾟﾙにしないとコードが長くなりすぎ、分かりにくくなるのでは？っと思い
質問させていただきます。

一回目の質問はわかりづらく失礼しました。

Sub 表の補完()

Dim i As Integer

For i = 5 To Cells(65536, 2).End(xlUp).Row

If Cells(i, 1) = "102" Then
Cells(i, 1).Offset(1).Select
Range(Selection, Selection.Offset(, 5)).Select
　　Selection.Insert shift:=xlDown
ActiveCell.Offset(, 1).Value = "PPP"
ActiveCell.Offset(, 2).Value = "0"
ActiveCell.Offset(, 3).Value = "0"
ActiveCell.Offset(, 4).Value = "0"
ActiveCell.Offset(, 5).Value = "0"
End If

If Cells(i, 1) = "107" Then
Cells(i, 1).Offset(1).Select
Range(Selection, Selection.Offset(, 5)).Select
　　Selection.Insert shift:=xlDown
ActiveCell.Offset(, 1).Value = "GGG"
ActiveCell.Offset(, 2).Value = "0"
ActiveCell.Offset(, 3).Value = "0"
ActiveCell.Offset(, 4).Value = "0"
ActiveCell.Offset(, 5).Value = "0"
End If

Next
End Sub


	【29038】Re:データの埋め込み

ichinose - 05/9/22(木) 8:29 -


	引用なし

	パスワード

▼M さん：
おはようございます。
まず、新規ブックにSheet1とSheet2というシート名持つシートを作成してください。

>元の表があります。これを仕上げの表のようにしたいのです。
>
>元の表　　項目１　　　項目２　　項目３　　項目４　　　項目５
>101　　　　AAA　　　　500　　　　300　　　　200　　　　500
>102　　　　BBB　　　　400　　　　100　　　　 50　　　　400
>104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
>105　　　　EEE　　　　150　　　　 50　　　　　0　　　　150
>107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
>109　　　　HHH　　　　180　　　　 80　　　　 50　　　　180

Sheet1のセルＡ１から、↑のデータが入力されているとします。

Sheet2のセルＡ１から、

　　　　Ａ　　　　　　Ｂ
１　　挿入項目　　　項目1
２　　　103　　　　ＰＰＰ
３　　　108　　　　ＧＧＧ

というように挿入するデータを入力します。
このように挿入するデータのありかを決めないと
繰り返し処理ができませんよね！！

標準モジュールに

'=============================================================
Sub test()
　　Dim strow As Long
　　Dim addrng As Range
　　With Worksheets("sheet2")
　　　Set addrng = .Range("a2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2)
　　　End With
　　If addrng.Row > 1 Then
　　　 With Worksheets("sheet1")
　　　　　strow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
　　　　　.Range(.Cells(strow, 1), .Cells(strow + addrng.Rows.Count - 1, 2)).Value = addrng.Value
　　　　　.Range(.Cells(strow, 3), .Cells(strow + addrng.Rows.Count - 1, 6)).Value = 0
　　　　　.Range("a1", .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 5)).Sort key1:=.Range("a1"), header:=xlYes
　　　　　End With
　　　 End If
End Sub

testを実行してみてください。

行を逐次挿入するのではなく、追加して並べ替えました。


	【29063】Re:データの埋め込み

M - 05/9/22(木) 21:25 -


	引用なし

	パスワード

▼ichinose さん：
親切な解答ありがとうございました。
よく理解できました。でも･･･

当方からの説明が不十分で、失礼致しました。
意図が伝わらずに苦慮しています。表現が十分に出来ず申し訳けございません。

　　　　　項目１　　　項目２　　項目３　　項目４　　　項目５
101　　　　AAA　　　　500　　　　300　　　　200　　　　500
102　　　　BBB　　　　400　　　　100　　　　 50　　　　400
104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
105　　　　EEE　　　　150　　　　 50　　　　　0　　　　150
107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
109　　　　HHH　　　　180　　　　 80　　　　 50　　　　180

上の表は、あるデータからエクセルに張り込んだデータです。
しかし103のPPPのデータが欠落された状態です。（その日に数字の全く動きのない状態のため、そのデータが消えて存在しない状態なのです）108のGGGも今日何ら動きが無いため
データの存在が無いのです。合計2行のデータが欠落しています。

仕上がりは下の表のようにしたいのです。
しかも、シート１だけでするようにしたいんですが。

又、明日のデータは変化します。例えば103のPPPの１列だけが無い状態かも知れません。

日計データの動きの無い場合は項目２～５まで０という数字を埋めて、いつも仕上がりの表が同じ行数・列数になるように仕上げたいんです。項目1のAAA～HHHは８行です。項目名と順番は変わりません。仕上がりも、いつも８行で仕上げたいんです。またできれば検索の列を項目１でしたいんですが。

説明が不十分ですが、申し訳けございませんが、よろしくお願いします。

仕上がり

　　　　項目1　　項目2　　項目3　　項目4　　項目5
101　　　　AAA　　　　500　　　　300　　　　200　　　　500
102　　　　BBB　　　　400　　　　100　　　　 50　　　　400
103　　　　PPP　　　　　0　　　　　0　　　　　0　　　　　0
104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
105　　　　EEE　　　　150　　　　 50　　　　　0　　　　150
107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
108　　　　GGG　　　　　0　　　　　0　　　　　0　　　　0
109　　　　HHH　　　　180　　　　 80　　　　 50　　　　180


	【29064】Re:データの埋め込み

ichinose - 05/9/22(木) 22:39 -


	引用なし

	パスワード

▼M さん：
こんばんは。

>
>当方からの説明が不十分で、失礼致しました。
>意図が伝わらずに苦慮しています。表現が十分に出来ず申し訳けございません。
苦慮してください・・・。後々には必ず、役に立ちます。
私は、そう思っています。

さて、再度、
新規ブックにSheet1とSheet2というシート名持つシートを作成してください。

>
>
>番号　　　項目１　　　項目２　　項目３　　項目４　　　項目５
>101　　　　AAA　　　　500　　　　300　　　　200　　　　500
>102　　　　BBB　　　　400　　　　100　　　　 50　　　　400
>104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
>105　　　　EEE　　　　150　　　　 50　　　　　0　　　　150
>107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
>109　　　　HHH　　　　180　　　　 80　　　　 50　　　　180
>

Sheet1のセルＡ１から、↑のデータが入力されているとします。

Sheet2のセルＡ１から、

　　　　Ａ　　　　Ｂ
１　　番号　　　項目1
２　　101　　　　AAA
３　　102　　　　BBB
４　　103　　　　PPP
５　　104　　　　DDD
６　　105　　　　EEE
７　　107　　　　FFF
８　　108　　　　GGG
９　　109　　　　HHH

というマスターデータ入力しておきます。

標準モジュールに

'============================================================
Sub test()
　　Dim strow As Long
　　Dim sh1rng As Range
　　Dim sh2rng As Range
　　With Worksheets("sheet1")
　　　Set sh1rng = .Range("a2", .Cells(.Rows.Count, 1).End(xlUp))
　　　End With
　　If sh1rng.Row > 1 Then
　　　 With Worksheets("sheet2")
　　　　　Set sh2rng = .Range("a2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　With sh2rng.Offset(0, 2)
　　　　　　 .Formula = "=if(countif(" & sh1rng.Offset(0, 1).Address(, , , True) & _
　　　　　　　　　　　　",b2)=0,0,"""")"
　　　　　　 On Error Resume Next
　　　　　　 Set addrng = .SpecialCells(xlCellTypeFormulas, xlNumbers)
　　　　　　 If Err.Number = 0 Then
　　　　　　　　strow = sh1rng.Row + sh1rng.Rows.Count
　　　　　　　　With Worksheets("sheet1")
　　　　　　　　　 For Each crng In addrng.Offset(0, -2)
　　　　　　　　　　　.Range(.Cells(strow, 1), .Cells(strow, 2)).Value = crng.Resize(, 2).Value
　　　　　　　　　　　.Range(.Cells(strow, 3), .Cells(strow, 6)).Value = 0
　　　　　　　　　　　strow = strow + 1
　　　　　　　　　　　Next
　　　　　　　　　 With .Range("a1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 6)
　　　　　　　　　　　.Sort key1:=.Range("a1"), header:=xlYes
　　　　　　　　　　　End With
　　　　　　　　　 End With
　　　　　　　 End If
　　　　　　 .Formula = ""
　　　　　　 On Error GoTo 0
　　　　　　 End With
　　　　　End With
　　　 End If
End Sub

これで、確認してください

>上の表は、あるデータからエクセルに張り込んだデータです。
>しかし103のPPPのデータが欠落された状態です。（その日に数字の全く動きのない状態のため、そのデータが消えて存在しない状態なのです）108のGGGも今日何ら動きが無いため
>データの存在が無いのです。合計2行のデータが欠落しています。
>
>仕上がりは下の表のようにしたいのです。
>しかも、シート１だけでするようにしたいんですが。
>
>又、明日のデータは変化します。例えば103のPPPの１列だけが無い状態かも知れません。
>
>日計データの動きの無い場合は項目２～５まで０という数字を埋めて、いつも仕上がりの表が同じ行数・列数になるように仕上げたいんです。項目1のAAA～HHHは８行です。項目名と順番は変わりません。仕上がりも、いつも８行で仕上げたいんです。またできれば検索の列を項目１でしたいんですが。
>
>説明が不十分ですが、申し訳けございませんが、よろしくお願いします。
>
>
>仕上がり
>
>　　　　項目1　　項目2　　項目3　　項目4　　項目5
>101　　　　AAA　　　　500　　　　300　　　　200　　　　500
>102　　　　BBB　　　　400　　　　100　　　　 50　　　　400
>103　　　　PPP　　　　　0　　　　　0　　　　　0　　　　　0
>104　　　　DDD　　　　600　　　　　0　　　　250　　　　600
>105　　　　EEE　　　　150　　　　 50　　　　　0　　　　150
>107　　　　FFF　　　　600　　　　　0　　　　　0　　　　600
>108　　　　GGG　　　　　0　　　　　0　　　　　0　　　　0
>109　　　　HHH　　　　180　　　　 80　　　　 50　　　　180


	【29083】Re:データの埋め込み

M - 05/9/23(金) 16:31 -


	引用なし

	パスワード

▼ichinose さん：

基準になる表が必要な事が良く分かりました。
それを別シートに作成して活用する事ですね。汎用性があって今後また
他のところにも、使わせていただきます。
素晴らしいマクロに、ちょっとついていけないのが事実です。
戸惑いを感じながらも、これで進めそうです。ありがとうございました。

幼稚なことを考え、自分なりに、コードを作成しました。
元の表は下のようなレイアウトになっています。
大体欠落する行が103のPPP、105のEEE、108のGGGです。
それで、それを踏まえてコードにしました。
しかし、マクロを２回しないと108のGGGが入ってくれません。
どこを直すと１回の操作で行くのでしょうか。もし時間が有りましたら
教えてください。

Sub 表の補完作成1()

Dim i As Integer

For i = 5 To Cells(65536, 2).End(xlUp).Row

If Cells(i, 1) = "102" Then
Cells(i, 1).Offset(1).Select

If Selection.Value <> "103" Then
Range(Selection, Selection.Offset(, 5)).Select
　　Selection.Insert shift:=xlDown
ActiveCell.Value = "103"
ActiveCell.Offset(, 1).Value = "PPP"
ActiveCell.Offset(, 2).Value = "0"
ActiveCell.Offset(, 3).Value = "0"
ActiveCell.Offset(, 4).Value = "0"
ActiveCell.Offset(, 5).Value = "0"
End If
End If

If Cells(i, 1) = "104" Then
Cells(i, 1).Offset(1).Select

If Selection.Value <> "105" Then
Range(Selection, Selection.Offset(, 5)).Select
　　Selection.Insert shift:=xlDown
ActiveCell.Value = "105"
ActiveCell.Offset(, 1).Value = "EEE"
ActiveCell.Offset(, 2).Value = "0"
ActiveCell.Offset(, 3).Value = "0"
ActiveCell.Offset(, 4).Value = "0"
ActiveCell.Offset(, 5).Value = "0"
End If
End If

If Cells(i, 1) = "107" Then
Cells(i, 1).Offset(1).Select

If Selection.Value <> "108" Then
Range(Selection, Selection.Offset(, 5)).Select
　　Selection.Insert shift:=xlDown
ActiveCell.Value = "108"
ActiveCell.Offset(, 1).Value = "GGG"
ActiveCell.Offset(, 2).Value = "0"
ActiveCell.Offset(, 3).Value = "0"
ActiveCell.Offset(, 4).Value = "0"
ActiveCell.Offset(, 5).Value = "0"

End If
End If

Next
End Sub

A　　　B　　　C　　　D　　　　E　　　　F　　　　　G
　　項目1　　項目2　　項目3　項目4　　項目5　　項目6
5　　101　　　　　　AAA　　　　　500　　　　300　　　　200　　　　500
6　　102　　　　　　BBB　　　　　400　　　　100　　　　 50　　　　400
7　　104　　　　　　DDD　　　　　600　　　　　0　　　　250　　　　600
8　　107　　　　　　FFF　　　　　600　　　　　0　　　　　0　　　　600
9　　109　　　　　　HHH　　　　　180　　　　 80　　　　 50　　　　180


	【29087】Re:データの埋め込み

ichinose - 05/9/23(金) 18:40 -


	引用なし

	パスワード

▼M さん：
こんばんは。

>
>基準になる表が必要な事が良く分かりました。
>それを別シートに作成して活用する事ですね。汎用性があって今後また
>他のところにも、使わせていただきます。
>素晴らしいマクロに、ちょっとついていけないのが事実です。
素晴らしいか否かはともかく、M さんが投稿されたコードと比較して
私が投稿したコードのアルゴリズムは単純です。
M さんのやろうとしている事は
かなりややこしいんですよ！！

これは、

>>Sub 表の補完作成1()
>
>Dim i As Integer
>
For i = Cells(65536, 2).End(xlUp).Row to 5 step -1
>
>If Cells(i, 1) = "102" Then
>Cells(i, 1).Offset(1).Select
>
>If Selection.Value <> "103" Then
>Range(Selection, Selection.Offset(, 5)).Select
>　　Selection.Insert shift:=xlDown
>ActiveCell.Value = "103"
>ActiveCell.Offset(, 1).Value = "PPP"
>ActiveCell.Offset(, 2).Value = "0"
>ActiveCell.Offset(, 3).Value = "0"
>ActiveCell.Offset(, 4).Value = "0"
>ActiveCell.Offset(, 5).Value = "0"
>End If
>End If
>
>If Cells(i, 1) = "104" Then
>Cells(i, 1).Offset(1).Select
>
>If Selection.Value <> "105" Then
>Range(Selection, Selection.Offset(, 5)).Select
>　　Selection.Insert shift:=xlDown
>ActiveCell.Value = "105"
>ActiveCell.Offset(, 1).Value = "EEE"
>ActiveCell.Offset(, 2).Value = "0"
>ActiveCell.Offset(, 3).Value = "0"
>ActiveCell.Offset(, 4).Value = "0"
>ActiveCell.Offset(, 5).Value = "0"
>End If
>End If
>
>If Cells(i, 1) = "107" Then
>Cells(i, 1).Offset(1).Select
>
>If Selection.Value <> "108" Then
>Range(Selection, Selection.Offset(, 5)).Select
>　　Selection.Insert shift:=xlDown
>ActiveCell.Value = "108"
>ActiveCell.Offset(, 1).Value = "GGG"
>ActiveCell.Offset(, 2).Value = "0"
>ActiveCell.Offset(, 3).Value = "0"
>ActiveCell.Offset(, 4).Value = "0"
>ActiveCell.Offset(, 5).Value = "0"
>
>End If
>End If
>
>Next
>End Sub

とすれば、動作すると思いますが、
これだと汎用性はないですよね？

これを私はこういうアルゴリズムで作成する事はないですが、

'=============================================================
Sub 表の補完作成1()
　　Dim i As Long
　　Dim chkarray1 As Variant
　　Dim chkarray2 As Variant
　　Dim jdx As Long
　　chkarray1 = Array(101, 102, 103, 104, 105, 107, 108, 109)
　　chkarray2 = Array("AAA", "BBB", "PPP", "DDD", "EEE", "FFF", "GGG", "HHH")
　　jdx = UBound(chkarray1)
　　i = Cells(65536, 1).End(xlUp).Row
　　Do Until jdx < 0
　　　With Cells(i, 1)
　　　　 If .Value <> chkarray1(jdx) Then
　　　　　　.Offset(1).EntireRow.Insert shift:=xlDown
　　　　　　.Offset(1, 0).Value = chkarray1(jdx)
　　　　　　.Offset(1, 1).Value = chkarray2(jdx)
　　　　　　.Offset(1, 2).Resize(, 4).Value = 0
　　　　 Else
　　　　　　If i >= 5 Then i = i - 1
　　　　　　End If
　　　　 End With
　　　jdx = jdx - 1
　　　Loop
End Sub

これで確認してみて下さい。
アルゴリズムは、こっちの方がややこしいですよ！！


	【29095】Re:データの埋め込み

M - 05/9/23(金) 21:59 -


	引用なし

	パスワード

▼ichinose さん：

今晩は。
ありがとうございました。
色々と勉強になりました。
最後の解答が、一番使いやすく、これを活用させていただきます。
これからもよろしくお願いします。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9145 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free