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

VBAについて質問です。
時間のある方以下のプログラムを作成していただきたいのですがよろしくお願いします。

Sheet1のA列にタイトルが入っておりSheet2のA列にもタイトルが入っています。
Sheet1とSheet2のタイトルを比較しSheet2のA列にあるタイトルがもしSheet1のタイトルと同じ場合
Sheet1のB列にある値をSheet2のB列に
Sheet1のC列にある値をSheet2のC列に書き込むという処理を繰り返し処理にて何回も行いたいと考えています。

このプログラムを書ける方おりましたらお手数をおかけしますがプログラムの記入をよろしくお願いします。

●質問者: aiomock
●カテゴリ:コンピュータ インターネット
✍キーワード:タイトル プログラム 作成 比較
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● SALINGER
●23ポイント ベストアンサー

Sheet1に、A列にタイトル、B列・C列にもデータが行ごとに入っているということでよろしいでしょうか?

処理はSheet2のA列にタイトルが行ごとに入っていて、Sheet1から同じタイトルを探して

Sheet2にデータをコピーするという処理になりますでしょうか?

その場合ならば、以下で。


Option Explicit

Sub Macro()
 Dim LastRow As Long
 Dim i As Long
 Dim res
 
 LastRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
 For i = 1 To LastRow
 If Sheet2.Cells(i, 1).Value <> "" Then
 Set res = Sheet1.Range("A:A").Find(Sheet2.Cells(i, 1).Value, , xlValues, xlWhole)
 If Not res Is Nothing Then
 Sheet2.Cells(i, 2).Value = res.Offset(0, 1).Value
 Sheet2.Cells(i, 3).Value = res.Offset(0, 2).Value
 End If
 End If
 Next i
End Sub
◎質問者からの返答

御回答ありがとうございます。試させて頂きます。


2 ● s-n-k
●23ポイント

質問の内容が一部不明でしたので、勝手な想像でプログラムを作ってみました。(もし望まれていない内容のプログラムでしたらごめんなさい。ポイントは不要です。)

Sheet1

A B C
1 a aa aaa
2 b bb bbb
3 c cc ccc

Sheet2(実行前)

A B C
1 a
2 c
3 d
4 b

Sheet2(実行後)

A B C
1 a aa aaa
2 c cc ccc
3 d
4 b bb bbb

というイメージになるということでよろしいでしょうか? でしたら以下のプログラムで実現できると思います。

Sub main()

 Dim SourceSheet As Worksheet
 Dim TargetSheet As Worksheet
 Dim SourceRange As Range
 Dim TargetRange As Range

 Set SourceSheet = Sheets("Sheet1")
 Set TargetSheet = Sheets("Sheet2")
 
 With SourceSheet
 Set SourceRange = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
 End With
 
 With TargetSheet
 Set TargetRange = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
 End With

 Dim t As Range
 Dim s As Range

 For Each t In TargetRange
 For Each s In SourceRange
 If s.Value = t.Value Then
 t.Offset(0, 1).Value = s.Offset(0, 1).Value
 t.Offset(0, 2).Value = s.Offset(0, 2).Value
 End If
 
 Next s
 Next t
 
End Sub
◎質問者からの返答

御回答ありがとうございます。そちらのイメージになります。

試させて頂きます。


3 ● van-dine
●22ポイント

Sheet1,Sheet2がシート名、空白セルがあったら終了の前提で書きます

Set R1 = Sheets("Sheet1").Range("A1")
Set R2 = Sheets("Sheet2").Range("A1")
'もし、Sheet1がオブジェクト名ならSheet1.Range(?)、以下同

Do While VarType(R1.Value) <> vbEmpty
 If R1.value = R2.value Then
 R1.Range("B1").value = R2.Range("B1").value
 R1.Range("C1").value = R2.Range("C1").value
 End If
 Set R1 = R1.Range("A2")
 Set R2 = R2.Range("A2")
Loop
◎質問者からの返答

御回答ありがとうございます。試させて頂きます。


4 ● ardarim
●22ポイント

Sheet2のA列のタイトルをSheet1のA列から探して、一致するものがあればB列、C列の内容をSheet2に転記するものです。

Sheet1のA列の内容は一意であることが前提です。重複するタイトルがある場合、最初に見つかったものを優先します。

Option Explicit

Sub test()

 Dim sht1 As Worksheet
 Dim sht2 As Worksheet
 Dim cl As Range
 Dim matchCell As Range
 Dim r As Long, m As Long
 
 Application.ScreenUpdating = False
 
 Set sht1 = ThisWorkbook.Worksheets("Sheet1")
 Set sht2 = ThisWorkbook.Worksheets("Sheet2")
 
 m = sht2.Cells.SpecialCells(xlCellTypeLastCell).Row
 For r = 1 To m
 If sht2.Cells(r, 1).Value <> "" Then
 Set matchCell = sht1.Columns(1).Find(sht2.Cells(r, 1).Value, , , xlWhole)
 If Not matchCell Is Nothing Then
 sht2.Cells(r, 2).Value = sht1.Cells(matchCell.Row, 2).Value
 sht2.Cells(r, 3).Value = sht1.Cells(matchCell.Row, 3).Value
 End If
 End If
 Next r

 Application.ScreenUpdating = True
 
End Sub
◎質問者からの返答

御回答ありがとうございます。試させて頂きます。

関連質問


●質問をもっと探す●



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