ここから本文です

マクロについて教えてください。 book1のsheet1のとある文字を検索 → その1つ...

sib********さん

2019/1/712:26:35

マクロについて教えてください。

book1のsheet1のとある文字を検索 → その1つ右隣のセルの値コピー→book2を起動→sheet2のB列へ値で貼り付けをする方法を教えてください。
※book2のA列には

項目名が記されており、book1の名前に該当する行のB列に値で貼り付けをしたいです。

例えば
book1の名前=りんご
検索キー=合計
検索キーの右隣=100
(A10に合計がある場合、B10をコピーするイメージです。

100をコピー

book2の名前=集計
を開く

sheet2のA列からbook1の名前を検索

そのセルの右隣にコピーした100を値で貼り付け
(A13にりんごがある場合、B13に貼り付けするイメージです)


という感じになります。
複雑で申し訳ないですが、よろしくお願いします。

閲覧数:
78
回答数:
3
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

set********さん

2019/1/1001:21:35

一度、下記の構文で試してみて下さい。
・「りんご」のブックに、下記の構文をコピペして実行してみて下さい。
・なお、「集計」「りんご」などのブックは、同じフォルダ内にあるものとします。

Sub 転記1() 'りんご⇒集計
Dim Data As Variant
Dim ThisBkNm As String, OutPath As String, OutBkNm As String

On Error Resume Next
ThisBkNm = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1)
With Workbooks(ThisWorkbook.Name).Sheets("Sheet1")
Data = .Range("B" & Application.Match("合計", .Range("A:A"), 0))
End With
If Data = "" Then Exit Sub
OutPath = ThisWorkbook.Path & "\" & "集計.xlsm"
OutBkNm = Dir(OutPath)
If OutBkNm = "" Then Exit Sub
Application.ScreenUpdating = False
Workbooks.Open OutPath
With Workbooks(OutBkNm).Sheets("Sheet2")
Range("B" & Application.Match(ThisBkNm, .Range("A:A"), 0)).Value = Data
End With
Workbooks(OutBkNm).Save
Workbooks(OutBkNm).Close
Application.ScreenUpdating = True
End Sub


ただ、貴殿のやりたいことは、下の図のように、
・左側の「集計」のブックの、A列の各商品名に一致する、
・中央の「りんご」や右側の「すいか」の「合計」数値を、
・「集計」のB列に転記したい、
ということではないのでしょうか?

もしそうなら、下記の構文を「集計」のブックにコピペして実行してみて下さい。

Sub 転記2() '集計←りんご
Dim buf As String
Dim ThisBkNm As String, InPath As String, InBkNm As String
Dim Data As Variant, LRow As Long

On Error Resume Next
LRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
InPath = ThisWorkbook.Path & "\"
buf = Dir(InPath & "*.xls*")
Application.ScreenUpdating = False
For Each rg In Sheets("Sheet2").Range("A1", "A" & LRow)
InPath = ThisWorkbook.Path & "\" & rg.Value & ".xls*"
buf = Dir(InPath)
If buf <> "" Then
InPath = ThisWorkbook.Path & "\" & buf
InBkNm = Left(buf, InStr(buf, ".") - 1)
Workbooks.Open InPath
With Workbooks(buf).Sheets("Sheet1")
Data = .Range("B" & Application.Match("合計", .Range("A:A"), 0))
End With
With Workbooks(ThisWorkbook.Name).Sheets("Sheet2")
.Range("B" & rg.Row).Value = Data
End With
Workbooks(buf).Saved = True
Workbooks(buf).Close
End If
Next rg
Application.ScreenUpdating = True
End Sub

一度、下記の構文で試してみて下さい。
・「りんご」のブックに、下記の構文をコピペして実行してみて下さい。...

  • 質問者

    sib********さん

    2019/1/1108:27:36

    まさかに下部にて、仰られている内容をやりたいです!
    しかし、ご回答いただいた内容では、
    何も起こりませんでした。

    前提として、開くのは転記先(集計)Excelのみで転記元のデータはデスクトップの「データ格納」というフォルダ内にある6つのExcelすべてです。

    どのように変更すればよいでしょうか?

  • その他の返信(1件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この回答は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

c72********さん

2019/1/717:39:50

book1もbook2も開かれてなく、第3のエクセルファイルから実行という前提です。

Sub Sample2()
Dim tmp1 As String, tmp2 As String
Dim key1 As String, key2 As String
Dim bk1 As String, bk2 As String
Dim fnd1 As Range, fnd2 As Range
Application.ScreenUpdating = False

'book1の対象シートを指定★
tmp1 = "Sheet1"
'book2の対象シートを指定★
tmp2 = "Sheet2"
'book1から検索するワード★
key1 = "合計"

'book1を開く
MsgBox "転記元ブックを選択してください。", vbQuestion, "ファイルを開く"
bk1 = Application.GetOpenFilename("Excel ブック,*.xls?")
Workbooks.Open bk1, ReadOnly:=True
'検索
Set fnd1 = Workbooks(Dir(bk1)).Sheets(tmp1).Cells.Find(What:=key1, LookAt:=xlWhole, LookIn:=xlValues)
If fnd1 Is Nothing Then
'ワードが無かった場合は終了
MsgBox tmp1 & "シートに" & key1 & "が見つかりません。", vbExclamation, "エラー"
GoTo XYZ
Exit Sub
End If

'book1の名前
key2 = Split(Dir(bk1), ".")(0)

'book2を開く
MsgBox "転記先ブックを選択してください。", vbQuestion, "ファイルを開く"
bk2 = Application.GetOpenFilename("Excel ブック,*.xls?")
Workbooks.Open bk2
'検索
Set fnd2 = Workbooks(Dir(bk2)).Sheets(tmp2).Range("A:A").Find(What:=key2, LookAt:=xlWhole, LookIn:=xlValues)
If fnd2 Is Nothing Then
'ワードが無かった場合は終了
MsgBox tmp2 & "シートに" & key2 & "が見つかりません。", vbExclamation, "エラー"
GoTo XYZ
Else
'値で転記
Workbooks(Dir(bk2)).Sheets(tmp2).Range(fnd2.Address).Offset(0, 1).Value = _
Workbooks(Dir(bk1)).Sheets(tmp1).Range(fnd1.Address).Offset(0, 1).Value
MsgBox "完了しました。", vbInformation, "完了"
End If

XYZ:
On Error Resume Next
Set fnd1 = Nothing
Set fnd2 = Nothing
'閉じる (book1は保存しない、book2はする)
Workbooks(Dir(bk1)).Close False
Workbooks(Dir(bk2)).Close True
Application.ScreenUpdating = True
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

bar********さん

2019/1/713:04:11

以下で 試して ください。

Set Rng = Cells.Find("合計")
If Not Rng Is Nothing Then
R = Rng.Row
C = Rng.Column
Sheet2.Cells(R, "B") = Sheet1.Cells(R, C + 1)
End If

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる