質問: Excel VBAについて、別ブックへの検索及びコピーについてご教示頂けないでしょうか。 【やりたいこと】 Book1:「記入用紙」 Book2:「データ一覧」 1.book1内に次のようにデータが入力されているとします。 A3セル:"abc" (文字列) A6セル:"日本" (文字列) 2.book2内の1行目にa ~ abcde...とデータが入力されています。(2~4行目はすべて文字列で埋まっています) 3.book1,A3セルに記入されている"abc"という文字列をbook2の1行目から検索し、そこから下に数えて一番初めにある空白セルにbook1,A6セルの"日本"という文字をコピー ※すでに記入されているセルもあるため、かならず5行目が空白という訳ではありません。 以上の動作が行えるようなマクロについてご教示いただけますと幸いです。 恥ずかしながら、別ブックを開いてアクティブにする点、find関数で文字列を検索した後の空白セルの指定の仕方等々調べたものの、実際に組み合わせるとどうなるかが良く理解できず、お力をお借りしたい次第です。 宜しくお願い致します。
回答: 前提がわからないので下記前提です。 ・「記入用紙」、「データ一覧」はともに同じフォルダーにある。 ・「記入用紙」にマクロを記述する。 ・「データ一覧」のシート名は「sheet1」とする。 ・マクロは、「記入用紙」で実施される。 ・Private Sub CommandButton1_Click()」は実施環境にあわせてください。 ・「データ一覧」の修飾子、シート名が違う場合は、提示コード内の sBookName = "データ一覧.xlsx" ''「データ一覧」のブック名 sSheetName = "sheet1" ''「データ一覧」のシート名 にある「””」中の文字を正しいものに修正してください。 Private Sub CommandButton1_Click() ''「記入用紙」のブック、シートを保存する。 Dim MyWb As Workbook, MyWs As Worksheet Set MyWb = ThisWorkbook Set MyWs = ActiveSheet ''「データ一覧」を取得する。 Dim Wb As Workbook, Ws As Worksheet Dim sBookName As String, sBookPath As String, sSheetName As String sBookName = "データ一覧.xlsx" ''「データ一覧」のブック名 sSheetName = "sheet1" ''「データ一覧」のシート名 sBookPath = MyWb.Path & "\" If (Dir(sBookPath & sBookName) = "") Then MsgBox "「" & sBookName & "」がみつかりません。", vbCritical + vbOKOnly Exit Sub End If ''「データ一覧」を開き、シートを選択する。 Application.ScreenUpdating = False Set Wb = Workbooks.Open(sBookPath & sBookName, UpdateLinks:=False) On Error GoTo ERROROCCURRED8010 Set Ws = Wb.Worksheets(sSheetName) ''データ設定の列を取得する。 Dim iColumn As Long On Error GoTo ERROROCCURRED8020 iColumn = Application.WorksheetFunction.Match(MyWs.Range("A3").Value, Ws.Range("1:1"), 0) On Error GoTo 0 ''データを設定する。 MyWs.Activate With Ws.Cells(Ws.Rows.CountLarge, iColumn).End(xlUp).Offset(1) .Value = MyWs.Range("A6").Value End With ''「データ一覧」を保存し、閉じる。 Application.DisplayAlerts = False On Error GoTo ERROROCCURRED8030 'Wb.Save Wb.Close SaveChanges:=True Application.DisplayAlerts = True Application.ScreenUpdating = True Exit Sub ''エラー発生時、対処する。 ERROROCCURRED8010: MsgBox "「" & sSheetName & "」シートがみつかりません。", vbCritical + vbOKOnly GoTo ERROROCCURRED8999 ERROROCCURRED8020: MsgBox "見出しに「" & MyWs.Range("A3").Value & "」がみつかりません。", vbCritical + vbOKOnly GoTo ERROROCCURRED8999 ERROROCCURRED8030: MsgBox "「" & sBookName & "」を保存できません。", vbCritical + vbOKOnly GoTo ERROROCCURRED8999 ERROROCCURRED8999: Application.DisplayAlerts = False Wb.Close SaveChanges:=False Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub