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

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

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


●質問者: anim130M
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:Excel ゲーム スイッチ セル テレビ
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● きゃづみぃ
●200ポイント
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つ一致したら同じ行と判断しました。

◎質問者からの返答

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

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


2 ● グラ娘。
●300ポイント ベストアンサー

プログラム組むのは(特に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

◎質問者からの返答

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

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


3 ● Ktwo
●25ポイント

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

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

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

4 ● きゃづみぃ
●0ポイント

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

[機器名]と[振分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
関連質問


●質問をもっと探す●



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