VBAについて質問です。

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

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

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

回答の条件
  • 1人2回まで
  • 登録:2008/10/04 08:52:45
  • 終了:2008/10/11 08:55:02

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692008/10/04 10:12:13

ポイント23pt

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
id:aiomock

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

2008/10/04 14:25:50

その他の回答(3件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692008/10/04 10:12:13ここでベストアンサー

ポイント23pt

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
id:aiomock

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

2008/10/04 14:25:50
id:s-n-k No.2

s-n-k回答回数27ベストアンサー獲得回数22008/10/04 10:40:04

ポイント23pt

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

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
id:aiomock

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

試させて頂きます。

2008/10/04 14:27:03
id:van-dine No.3

van-dine回答回数108ベストアンサー獲得回数112008/10/04 10:55:34

ポイント22pt

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
id:aiomock

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

2008/10/04 14:27:08
id:ardarim No.4

ardarim回答回数892ベストアンサー獲得回数1422008/10/04 14:19:46

ポイント22pt

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
id:aiomock

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

2008/10/04 14:27:11

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

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

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

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

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