人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセル2003
画像と前回の質問を参照下さい。http://q.hatena.ne.jp/1325646546
1.シートA、シートBがあります
2.ナンバーを軸(同一のナンバーは存在しません)に
シートAに在ってシートBにないものはシートCには載せない
3.シートBに在ってAにないものはCに載せる
4.AとB両方にある場合はBの情報をCに載せる
5.シートCにはタイトルのみがあります
6-1.シートAにある番号順に並ぶ
6-2.シートAになくてシートBにある番号、つまり新たな番号はシートAの
番号の最後に追加される並び順でシートCに反映される
6-3.シートAにありシートBにない番号、つまり削除される番号はシートAの
番号順から削除(行削除)されシートCに反映される
7.A列は空白(開けておく)
8.タイトルであるB4?AVは触らない
9.データ開始はA6から。でも終わりはA1000ぐらいまである
10.横は今はAVだが将来AV以上に増える可能性がある
11.マクロはThisWorkbookに貼ればいい?のレベルですのでどこに式を張り付ければ
いいのかも教えて下さい。

これをマクロで、ボタンをポチと押せばサッサッサーとできるよう
お願いいたします。質問などはコメント欄にお書きください。

1326358523
●拡大する


●質問者: namaewa_5
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● TransFreeBSD
●100ポイント

マクロは通常標準モジュールに貼ります。
ボタン作成も含め基本的なところは下記などを参考にしてください。

で、コードの前に仕様ですが、

  1. 画像が小さくわかりにくいのですが、ナンバー列は「G」
  2. 3で「シートCに載せる」とあり、シートAに言及がありませんが、6-2「シートAの番号の最後に追加される並び順で」とあるので、シートAにも追加する
  3. シートAとシートCは、6-2でシートBにあるものが追加され、6-3でシートBにないものが消されるため
    • シートBは変更なしで、シートAとシートCが変更される
    • 3つのシートの行数は等しくなる
    • シートAとシートCは並び順が同じになる
    • シートBとシートCは並び順が違うがデータが同じになる
    • シートAとシートBに元々あった、シートAのデータはそのまま変更しない
  4. データの追加、削除の動作は該当行のB列からAV列までをコピーして貼り付け、または削除で、それ以外の場所のデータはそのまま

以上の様に作りました。あっていますか?

以下コード
範囲等は適宜修正してください。
マクロでの変更はアンドゥが利きませんのでファイルのバックアップを忘れないでください。

Option Explicit

Sub Macro1()
  ' データ対象範囲を指定
  ' 変更があれば修正してください
 Const startCol = "B" ' 開始列
 Const indexCol = "G" ' ナンバー列
 Const endCol = "AV" ' 終了列
 Const startRow = 6 ' 開始行
  '
 Dim endRowA As Long
 Dim endRowB As Long
 Dim endRowC As Long
 Dim indexA As Range
 Dim indexB As Range
 Dim sheetA As Worksheet
 Dim sheetB As Worksheet
 Dim sheetC As Worksheet
 Dim i As Long
 Dim res As Object
  ' それぞれのシートを指定
  ' シート名に合わせて変更してください
 Set sheetA = Worksheets("SheetA")
 Set sheetB = Worksheets("SheetB")
 Set sheetC = Worksheets("SheetC")
  '
  ' シートAとシートBの最終行を求める
 endRowA = sheetA.Cells(sheetA.Rows.Count, indexCol).End(xlUp).Row
 endRowB = sheetB.Cells(sheetB.Rows.Count, indexCol).End(xlUp).Row
  ' シートCのデータの追加行-1
 endRowC = startRow - 1
 
  ' シートBのインデックスとなるナンバーの範囲
 Set indexB = sheetB.Range(sheetB.Cells(startRow, indexCol), sheetB.Cells(endRowB, indexCol))
  ' まずシートAの上から順に見ていく
 i = startRow
 While i <= endRowA
  ' シートBから同じナンバーを探す
 Set res = indexB.Find(what:=sheetA.Cells(i, indexCol).Value, _
 LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
 If res Is Nothing Then
  ' 見つからなかったらシートAから消す
 sheetA.Range(sheetA.Cells(i, startCol), sheetA.Cells(i, endCol)) _
 .Delete Shift:=xlShiftUp
 endRowA = endRowA - 1
 Else
  ' 見つかったらシートCにコピーする
 endRowC = endRowC + 1
 sheetB.Range(sheetB.Cells(res.Row, startCol), sheetB.Cells(res.Row, endCol)) _
 .Copy Destination:=sheetC.Cells(endRowC, startCol)
 i = i + 1
 End If
 Wend

  ' シートAのインデックスとなるナンバーの範囲
 Set indexA = sheetA.Range(sheetA.Cells(startRow, indexCol), sheetA.Cells(endRowA, indexCol))
  ' 次にシートBの上から順に見ていく
 For i = startRow To endRowB
  ' シートAから同じナンバーを探す
 Set res = indexA.Find(what:=sheetB.Cells(i, indexCol).Value, _
 LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
 If res Is Nothing Then
  ' 見つからなかったらシートAとシートCにコピーする
 endRowA = endRowA + 1
 sheetB.Range(sheetB.Cells(i, startCol), sheetB.Cells(i, endCol)) _
 .Copy Destination:=sheetA.Cells(endRowA, startCol)
 endRowC = endRowC + 1
 sheetB.Range(sheetB.Cells(i, startCol), sheetB.Cells(i, endCol)) _
 .Copy Destination:=sheetC.Cells(endRowC, startCol)
 End If
 Next i
End Sub

[追記]
手元では下記のサンプルデータでテストしました。

シートAABCDシートBABCDシートCABCD
333
4表題B表題C表題D4表題B表題C表題D4表題B表題C表題D
5データ1ナンバーデータ25データ1ナンバーデータ25データ1ナンバーデータ2
61616
72777
838E5L8
94949
10510610

マクロの範囲指定の部分は下記の様にあわせます。

 Const indexCol = "C" ' ナンバー列
 Const endCol = "D" ' 終了列

実行結果は以下の様になります。

シートAABCDシートBABCDシートCABCD
333
4表題B表題C表題D4表題B表題C表題D4表題B表題C表題D
5データ1ナンバーデータ25データ1ナンバーデータ25データ1ナンバーデータ2
616161
747774
858E5L8E5L
979497
106106106

「同じ番号しか反映されない」の同じ番号とはシートAとシートB両方に存在するナンバー、上記では1, 4, 5の事で、
それしかシートCにコピーされないという事でしょうか。
その時シートAはどうなっているのでしょうか?

あと、数式は使われているのでしょうか?
動作としては通常のコピー→貼り付け、または削除を行っているので、数式で別の行の参照があると数値が変わったりするかもしれません。


namaewa_5さんのコメント
同じ番号しか反映されないです・・・ 画像が何枚かUPできる、もしくはエクセルファイルが アップできるところを教えていただけますでしょうか。 そのほうが説明が早いので。 その後、改めて回答いただけると嬉しいです! 何から何まですみません・・・追加でポイント送信しました!

TransFreeBSDさんのコメント
画像であればこちらをどうぞ。 http://f.hatena.ne.jp/help#upload 既にログインしているはてなのサービスですから「アップロード」のリンクから即時使えます。

TransFreeBSDさんのコメント
ファイルアップロードは、使ったことはありませんが、 https://okurin.bitpark.co.jp/ http://box.raksul.com/ あたりが簡単に使えそうです。

TransFreeBSDさんのコメント
サンプルデータでの実行結果と疑問点を追記しました。 あと、すみませんが土日は回答できない可能性が高いです。

namaewa_5さんのコメント
ファイルアップロードしました https://okurin.bitpark.co.jp/d.php?u=4e2aeTrerooLfXg

namaewa_5さんのコメント
行も1000件まで行くこともありますし、 列もBLなど増やす可能性があります。

TransFreeBSDさんのコメント
見ましたが、結構変更ありますね。今日中は無理かも知れません。 ちなみに、シートAは修正なしで良いのですよね?

namaewa_5さんのコメント
そうです。シートA、Bは何もしません。

2 ● TransFreeBSD
●100ポイント ベストアンサー

書式や数式の設定用にひな形となるシートを使うようにしました。
「SheetD」という名前のシートを作り、A6:BK6に罫線と各セルの書式のほか、A6にはナンバリング用に「=ROW(A6)-5」を、BG6:BH6にはそれぞれ計算式を入れておいてください。
それが各行にコピーされます。
あと、SheetCが無ければ自動的作ります。その際、SheetDの内容をコピーしますので、SheetDのA4:BK5にタイトルを入れておけばコピーされます。

Option Explicit

Sub Macro1()
  ' データ対象範囲を指定
  ' 変更があれば修正してください
 Const sheetNameA = "SheetA" ' シートAの名前
 Const sheetNameB = "SheetB" ' シートBの名前
 Const sheetNameC = "SheetC" ' シートCの名前
 Const sheetNameD = "SheetD" ' 書式シートの名前
 Const startRowA = 6 ' シートAの開始行
 Const startRowB = 2 ' シートBの開始行
 Const startRowC = startRowA ' シートCの開始行
 Const startRowD = startRowA ' 書式シートの開始行
 Const indexColA = "M" ' シートAのナンバー列
 Const indexColB = "F" ' シートBのナンバー列
 Const indexColC = indexColA ' シートCのナンバー列
  '
  ' データコピーを行う範囲の設定値
  ' 書式シートからシートCへデータをコピーする範囲の設定(数式も含めて)
 Dim fromD As Variant
 fromD = Array("A:BK", "A") ' 書式シートのA:BKをシートCのAからの範囲へ行う
  '
  ' シートAからシートCへデータをコピーする範囲(書式も含めて)
 Dim fromA As Variant
 fromA = Array("B:BK", "B") ' シートAのB:BKをシートCのBからの範囲へ行う
  '
  ' シートBからシートCへデータをコピーする範囲(これは複数からなる)
  ' シートBのA:EをシートCのBからの範囲へ行う、など
 Dim fromB As Variant
 fromB = Array( _
 Array("A:E", "B"), _
 Array("F:H", "M"), _
 Array("I", "AZ"), _
 Array("J:N", "BB"), _
 Array("O:Q", "BI"))
  '
 Dim endRowA As Long
 Dim endRowB As Long
 Dim endRowC As Long
 Dim indexA As Range
 Dim indexB As Range
 Dim sheetA As Worksheet
 Dim sheetB As Worksheet
 Dim sheetC As Worksheet
 Dim sheetD As Worksheet
 Dim i As Long
 Dim j As Long
 Dim res As Object
  ' それぞれのシート
 Set sheetA = Worksheets(sheetNameA)
 Set sheetB = Worksheets(sheetNameB)
 Set sheetD = Worksheets(sheetNameD)
  ' シートAとシートBの最終行を求める
 endRowA = sheetA.Cells(sheetA.Rows.Count, indexColA).End(xlUp).Row
 endRowB = sheetB.Cells(sheetB.Rows.Count, indexColA).End(xlUp).Row
  ' シートCのデータの追加行-1
 endRowC = startRowC - 1
 
  ' シートCの存在確認
 For Each sheetC In Worksheets
 If sheetC.Name = sheetNameC Then Exit For
 Next sheetC
  ' シートCが無ければ作る
 If sheetC Is Nothing Then
 Set sheetC = Worksheets.Add(Type:=xlWorksheet)
 sheetC.Name = sheetNameC
  ' 書式シートから表題部分をコピーする
 sheetD.Columns(fromD(0)) _
 .Copy Destination:=sheetC.Cells(1, fromD(1))
 End If
 
  ' 画面更新を一時停止
 Application.ScreenUpdating = False
  ' シートBのインデックスとなるナンバーの範囲
 Set indexB = sheetB.Range(sheetB.Cells(startRowB, indexColB), _
 sheetB.Cells(endRowB, indexColB))
  ' まずシートAの上から順に見ていく
 For i = startRowA To endRowA
  ' シートBから同じナンバーを探す
 Set res = indexB.Find(what:=sheetA.Cells(i, indexColA).Formula, _
 LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
 If Not res Is Nothing Then
  ' 見つかったら書式シート、シートA、シートBの値の順でコピーする
 endRowC = endRowC + 1
 sheetD.Columns(fromD(0)).Rows(startRowD) _
 .Copy Destination:=sheetC.Cells(endRowC, fromD(1))
 sheetA.Columns(fromA(0)).Rows(i) _
 .Copy Destination:=sheetC.Cells(endRowC, fromA(1))
 For j = LBound(fromB) To UBound(fromB)
 res.EntireRow.Columns(fromB(j)(0)).Copy
 sheetC.Cells(endRowC, fromB(j)(1)) _
 .PasteSpecial Paste:=xlPasteValues
 Next j
 End If
 Next i

  ' シートAのインデックスとなるナンバーの範囲
 Set indexA = sheetA.Range(sheetA.Cells(startRowA, indexColA), _
 sheetA.Cells(endRowA, indexColA))
  ' 次にシートBの上から順に見ていく
 For i = startRowB To endRowB
  ' シートAから同じナンバーを探す
 Set res = indexA.Find(what:=sheetB.Cells(i, indexColB).Formula, _
 LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, Matchbyte:=True)
 If res Is Nothing Then
  ' 見つからなかったら書式シートから数式・書式を含めてコピーした後シートBの値をコピーする
 endRowC = endRowC + 1
 sheetD.Columns(fromD(0)).Rows(startRowD) _
 .Copy Destination:=sheetC.Cells(endRowC, fromD(1))
 For j = LBound(fromB) To UBound(fromB)
 sheetB.Columns(fromB(j)(0)).Rows(i).Copy
 sheetC.Cells(endRowC, fromB(j)(1)) _
 .PasteSpecial Paste:=xlPasteValues
 Next j
 End If
 Next i
 Application.ScreenUpdating = True
End Sub

namaewa_5さんのコメント
ありがとうございました! 今後ともよろしくお願いします!
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ