1326358523 エクセル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に貼ればいい?のレベルですのでどこに式を張り付ければ
 いいのかも教えて下さい。

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

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2012/01/12 17:55:25
  • 終了:2012/01/18 22:00:41

ベストアンサー

id:TransFreeBSD No.2

TransFreeBSD回答回数661ベストアンサー獲得回数2642012/01/16 13:36:00

ポイント100pt

書式や数式の設定用にひな形となるシートを使うようにしました。
「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
id:namaewa_5

ありがとうございました!
今後ともよろしくお願いします!

2012/01/18 22:00:04

その他の回答(1件)

id:TransFreeBSD No.1

TransFreeBSD回答回数661ベストアンサー獲得回数2642012/01/12 21:40:54

ポイント100pt

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

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

  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はどうなっているのでしょうか?

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

他6件のコメントを見る
id:TransFreeBSD

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

2012/01/15 14:23:54
id:namaewa_5

そうです。シートA、Bは何もしません。

2012/01/15 17:39:06
id:TransFreeBSD No.2

TransFreeBSD回答回数661ベストアンサー獲得回数2642012/01/16 13:36:00ここでベストアンサー

ポイント100pt

書式や数式の設定用にひな形となるシートを使うようにしました。
「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
id:namaewa_5

ありがとうございました!
今後ともよろしくお願いします!

2012/01/18 22:00:04

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません