Excelのマクロに関する質問です。良い回答は、200ポイント差し上げます。

ファイルに2つのシートがあり、シート間で行の2つのセル内容を比較し、同じ内容であれば一部上書きし、
内容が違えば、最終行にデータを追加したい。

【Aリスト】新しいリスト
3  機器名  部品名   振分NO
4  テレビ  スイッチ  k0505
5  ビデオ  リモコン  c4412
6  ゲーム  ボタン   b3399  

【Bリスト】古いリスト
3  機器名   部品名   振分NO
4  テレビ   リモコン  k0505
5  ビデオ   リモコン  c4412

【実行後のBリスト】古いリストにAリストを更新
3  機器名  部品名   振分NO
4  テレビ  スイッチ  k0505
5  ビデオ  リモコン  c4412
6  ゲーム  ボタン   b3399

どうか宜しくお願いします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2010/11/22 22:06:52
  • 終了:2010/11/26 23:46:09

ベストアンサー

id:grankoyama No.2

グラ娘。回答回数560ベストアンサー獲得回数1702010/11/22 23:35:58

ポイント300pt

プログラム組むのは(特にVBA)久しぶりなのであれですが、、

先頭の3~6という数字は行番号、内容はキーでありそうな振分NO、一部上書きとは機器名と部品名を更新だと解釈しました。

違ってたらリトライします。

Const DataStartLine As Integer = 4 'データの始まる行数

Const MainNameCol As Integer = 1 '機器名の列数

Const SubNameCol As Integer = 2 '部品名の列数

Const KeyNameCol As Integer = 3 '振分NOの列数


Sub ListUpDate()


  Dim NewDataSheet As Worksheet '更新用リスト

  Dim OldDataSheet As Worksheet '古いリスト


  Set NewDataSheet = Application.Worksheets("Aリスト")

  Set OldDataSheet = Application.Worksheets("Bリスト")


  'とりあえずまわす

  Dim i As Integer

  i = DataStartLine


  While NewDataSheet.Cells(i, KeyNameCol) <> ""

    Dim j As Integer

    j = DataStartLine


    'とりあえずまわす

    Do While OldDataSheet.Cells(j, KeyNameCol) <> ""

      '一致した

      If NewDataSheet.Cells(i, KeyNameCol) = OldDataSheet.Cells(j, KeyNameCol) Then

        'データのコピー

        OldDataSheet.Cells(j, MainNameCol) = NewDataSheet.Cells(i, MainNameCol)

        OldDataSheet.Cells(j, SubNameCol) = NewDataSheet.Cells(i, SubNameCol)

        Exit Do

      End If

      j = j + 1

    Loop


    '最後まで回ってしまったということは一致データなし

    If OldDataSheet.Cells(j, KeyNameCol) = "" Then

      'データの追加

      OldDataSheet.Cells(j, MainNameCol) = NewDataSheet.Cells(i, MainNameCol)

      OldDataSheet.Cells(j, SubNameCol) = NewDataSheet.Cells(i, SubNameCol)

      OldDataSheet.Cells(j, KeyNameCol) = NewDataSheet.Cells(i, KeyNameCol)

    End If


    i = i + 1

  Wend

End Sub

id:anim130M

回答ありがとうございます。

補足として、一致する基準(キー)は[機器名]と[振分NO]で、[部品名]は更新セル(上書)になります。

2010/11/22 23:47:43

その他の回答(3件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982010/11/22 22:47:49

ポイント200pt
Sub 実行()

a = "Aリスト"
b = "Bリスト"


For a1 = 4 To 65536
    If Worksheets(a).Cells(a1, "A") = "" Then Exit Sub
    f = 1
    For b1 = 4 To 65536
        If Worksheets(b).Cells(b1, "A") = "" Then Exit For
        
        g = 0
        'どれだけ一致するのかチェック
        If Worksheets(a).Cells(a1, "A") = Worksheets(b).Cells(b1, "A") Then g = g + 1
        If Worksheets(a).Cells(a1, "B") = Worksheets(b).Cells(b1, "B") Then g = g + 1
        If Worksheets(a).Cells(a1, "C") = Worksheets(b).Cells(b1, "C") Then g = g + 1
        
        '2つ一致したら 同じ行とみなす?
        If g >= 2 Then
            Worksheets(b).Cells(a1, "A") = Worksheets(a).Cells(b1, "A")
            Worksheets(b).Cells(a1, "B") = Worksheets(a).Cells(b1, "B")
            Worksheets(b).Cells(a1, "C") = Worksheets(a).Cells(b1, "C")
            f = 0
            Exit For
        End If
    Next b1
                
    If f = 1 Then
        c = Worksheets(b).Cells(65536, "A").End(xlUp).Row + 1
        Worksheets(b).Cells(c, "A") = Worksheets(a).Cells(a1, "A")
        Worksheets(b).Cells(c, "B") = Worksheets(a).Cells(a1, "B")
        Worksheets(b).Cells(c, "C") = Worksheets(a).Cells(a1, "C")
    End If
Next a1

End Sub

一致する基準というのが ちょっと あいまいかなと思います。

とりあえず 2つ一致したら同じ行と判断しました。

id:anim130M

回答ありがとうございます。

補足として、一致する基準(キー)は[機器名]と[振分NO]で、[部品名]は更新セル(上書)になります。

2010/11/22 23:47:38
id:grankoyama No.2

グラ娘。回答回数560ベストアンサー獲得回数1702010/11/22 23:35:58ここでベストアンサー

ポイント300pt

プログラム組むのは(特にVBA)久しぶりなのであれですが、、

先頭の3~6という数字は行番号、内容はキーでありそうな振分NO、一部上書きとは機器名と部品名を更新だと解釈しました。

違ってたらリトライします。

Const DataStartLine As Integer = 4 'データの始まる行数

Const MainNameCol As Integer = 1 '機器名の列数

Const SubNameCol As Integer = 2 '部品名の列数

Const KeyNameCol As Integer = 3 '振分NOの列数


Sub ListUpDate()


  Dim NewDataSheet As Worksheet '更新用リスト

  Dim OldDataSheet As Worksheet '古いリスト


  Set NewDataSheet = Application.Worksheets("Aリスト")

  Set OldDataSheet = Application.Worksheets("Bリスト")


  'とりあえずまわす

  Dim i As Integer

  i = DataStartLine


  While NewDataSheet.Cells(i, KeyNameCol) <> ""

    Dim j As Integer

    j = DataStartLine


    'とりあえずまわす

    Do While OldDataSheet.Cells(j, KeyNameCol) <> ""

      '一致した

      If NewDataSheet.Cells(i, KeyNameCol) = OldDataSheet.Cells(j, KeyNameCol) Then

        'データのコピー

        OldDataSheet.Cells(j, MainNameCol) = NewDataSheet.Cells(i, MainNameCol)

        OldDataSheet.Cells(j, SubNameCol) = NewDataSheet.Cells(i, SubNameCol)

        Exit Do

      End If

      j = j + 1

    Loop


    '最後まで回ってしまったということは一致データなし

    If OldDataSheet.Cells(j, KeyNameCol) = "" Then

      'データの追加

      OldDataSheet.Cells(j, MainNameCol) = NewDataSheet.Cells(i, MainNameCol)

      OldDataSheet.Cells(j, SubNameCol) = NewDataSheet.Cells(i, SubNameCol)

      OldDataSheet.Cells(j, KeyNameCol) = NewDataSheet.Cells(i, KeyNameCol)

    End If


    i = i + 1

  Wend

End Sub

id:anim130M

回答ありがとうございます。

補足として、一致する基準(キー)は[機器名]と[振分NO]で、[部品名]は更新セル(上書)になります。

2010/11/22 23:47:43
id:Ktwo No.3

Ktwo回答回数21ベストアンサー獲得回数52010/11/23 02:29:39

ポイント25pt

勝手ながら「元の並び順を保持しなくても構わない」と致しまして、

並び替え~フィルターの処理を考えてみました^^;)

A列:機器名

B列:部品名

C列:振分NO

として、マクロを作成しています。

Option Compare Text

Const sName_A = "Aリスト"
Const sName_B = "Bリスト"
Const sName_B_New = "実行後のBリスト"
Const iStart_Row = 4

Sub Marge_A_and_B()
On Error GoTo Marge_A_and_B_Error

Dim sRange_New  As String
Dim sRange_A    As String
Dim sRange_B    As String
Dim sRange_WK   As String
    
    '実行後のBリスト作成
    Sheets(sName_B).Copy After:=Sheets(sName_B)
    Sheets(sName_B & " (2)").Name = sName_B_New
    sRange_New = "A" & iStart_Row & _
                 ":A" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_New).EntireRow.Delete
    
    '作業用シート作成
    Sheets(sName_B).Copy After:=Sheets(sName_B)
    Sheets(sName_B & " (2)").Name = "作業用"
    Range("D" & iStart_Row).Value = "B"
    Range("D" & iStart_Row).Copy
    sRange_WK = "D" & iStart_Row + 1 & _
                ":D" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_WK).Select
    ActiveSheet.Paste
    
    'Aリストを、作業用にコピー
    Sheets(sName_A).Select
    sRange_A = "A" & iStart_Row & _
               ":C" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_A).Select
    Selection.Copy
    Sheets("作業用").Select
    sRange_B = "A" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1
    Range(sRange_B).Select
    ActiveSheet.Paste
    
    '作業用シートを並び替え
    sRange_WK = "A" & iStart_Row & _
                ":D" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_WK).Select
    Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, _
                   Key2:=Range("C4"), Order2:=xlAscending, _
                   Key3:=Range("D4"), Order2:=xlDescending
        
    'フィルター列を作成
    Range("E" & iStart_Row - 1).Value = "フィルター"
    Range("E" & iStart_Row).Select
    ActiveCell.FormulaR1C1 = "=(RC[-4]=R[1]C[-4]) * (RC[-2]=R[1]C[-2])"
    Selection.Copy
    sRange_WK = "E" & iStart_Row + 1 & _
                ":E" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_WK).Select
    ActiveSheet.Paste
    
    'フィルター処理
    sRange_WK = "E" & iStart_Row - 1 & _
                ":E" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_WK).Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="0"
    
    '実行後のBリストへ、フィルターの結果を貼付け
    sRange_WK = "A" & iStart_Row & _
                ":C" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    Range(sRange_WK).Select
    Selection.Copy
    Sheets(sName_B_New).Select
    Range("A" & iStart_Row).Select
    ActiveSheet.Paste
    
    '終了処理
    Application.CutCopyMode = False
    Range("A1").Select

    MsgBox "Finished"
    
    Exit Sub
    
Marge_A_and_B_Error:

    MsgBox "!! Error !!" & vbCr & vbCr & Err.Description
    
End Sub
id:taknt No.4

きゃづみぃ回答回数13537ベストアンサー獲得回数11982010/11/26 22:31:07

まだ解決になっていないということは、コメントを読まれてない恐れがありますので

[機器名]と[振分NO]で一致か判断するように修正したものを 回答します。

Sub 実行()

a = "Aリスト"
b = "Bリスト"


For a1 = 4 To 65536
    If Worksheets(a).Cells(a1, "A") = "" Then Exit Sub
    f = 1
    For b1 = 4 To 65536
        If Worksheets(b).Cells(b1, "A") = "" Then Exit For
        
        g = 0
        'どれだけ一致するのかチェック
        If Worksheets(a).Cells(a1, "A") = Worksheets(b).Cells(b1, "A") Then g = g + 1
        If Worksheets(a).Cells(a1, "C") = Worksheets(b).Cells(b1, "C") Then g = g + 1
        
        '同じ行だったら
        If g >= 2 Then
            Worksheets(b).Cells(a1, "B") = Worksheets(a).Cells(b1, "B")
            f = 0
            Exit For
        End If
    Next b1
                
    If f = 1 Then
        c = Worksheets(b).Cells(65536, "A").End(xlUp).Row + 1
        Worksheets(b).Cells(c, "A") = Worksheets(a).Cells(a1, "A")
        Worksheets(b).Cells(c, "B") = Worksheets(a).Cells(a1, "B")
        Worksheets(b).Cells(c, "C") = Worksheets(a).Cells(a1, "C")
    End If
Next a1

End Sub
  • id:grankoyama
    グラ娘。 2010/11/23 00:20:43
    『i = DataStartLine』以降の差分です。
    本来は、機器名と振分NOの両方一致で一致とするのか片方だけでよいのかあらかじめ確認
    すべきですが、両方一致で作りました。

      'とりあえずまわす
      'どっちかが空ならループ終了
      While NewDataSheet.Cells(i, MainNameCol) <> "" And NewDataSheet.Cells(i, KeyNameCol) <> ""
        Dim j As Integer
        j = DataStartLine

        'どっちかが空ならループ終了
        Do While OldDataSheet.Cells(j, MainNameCol) <> "" And OldDataSheet.Cells(j, KeyNameCol) <> ""
          '一致した
          If NewDataSheet.Cells(i, MainNameCol) = OldDataSheet.Cells(j, MainNameCol) And NewDataSheet.Cells(i, KeyNameCol) = OldDataSheet.Cells(j, KeyNameCol) Then
            'データのコピー
            OldDataSheet.Cells(j, SubNameCol) = NewDataSheet.Cells(i, SubNameCol)
            Exit Do
          End If

        j = j + 1
        Loop

        '最後まで回ってしまったということは一致データなし
        If OldDataSheet.Cells(j, KeyNameCol) = "" Then
        'データの追加
          OldDataSheet.Cells(j, MainNameCol) = NewDataSheet.Cells(i, MainNameCol)
          OldDataSheet.Cells(j, SubNameCol) = NewDataSheet.Cells(i, SubNameCol)
          OldDataSheet.Cells(j, KeyNameCol) = NewDataSheet.Cells(i, KeyNameCol)
        End If

        i = i + 1
      Wend
    End Sub
  • id:taknt
    If Worksheets(a).Cells(a1, "B") = Worksheets(b).Cells(b1, "B") Then g = g + 1

    この行を削除すれば [機器名]と[振分NO]の一致だけになります。

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

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

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

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