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

2つのブック間の文字列を比較し、一致したら指定のセルから移動したデータをコピーし、もう片方ブックの指定のセルに貼り付けたいです。

Excelの質問です。
今、ブックAのR列には、

※(行目)|文字列

1|たちつてと
2|(空白セル)
3|あいうえお
4|かきくけこ
5|さしすせそ
6|(空白セル)
7|あいうえお




と、空白セルと文字列が入ったデータが6万行ほど混じって入ってます。

そしてブックBのB列にも、

1|さしすせそ
2|(空白セル)
3|あいうえお
4|あいうえお
5|あいうえお
6|(空白セル)
7|かきくけこ




と、同じく文字列セルと空白セルがずらりと6万行ほど入ってます。

この状況におきまして。
ブックA・R列とブックB・B列の文字列をそれぞれ比較(空白セルは無視)し、完全一致した場合、ブックB・B列の該当セルから右に15、下に1つ移動したセル(Q列)をコピーして。
ブックA・R列の該当セルから右に16、下に1つ移動したセル(AH列)に貼り付けたいのです。

そのような処理がマクロ等で可能でしたらお教えいただけないでしょうか。

●質問者: moon-fondu
●カテゴリ:コンピュータ 学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

質問者から

前回も似たような質問 http://q.hatena.ne.jp/1458683287 をさせていただいたのですが。
今回はルールがありまして、両ブックとも「重複データは一番最初のデータのみを使用」(重複データを無視、一回のみ採用)したい点です。
例えばブックAでは“あいうえお”がR3とR7セルに出てきますが。R7は無視していただきます。そしてR3がブックBのB列のどこで一番最初に出てくるかを探します。
するとブックBで“あいうえお”が最初に出てくるのはB3セルなので、その他のB4・B5セルは無視します。
B3セルから右に15、下に1つ移動したセルはQ4セルなので、それをコピーしまして。
ブックAのR3セルから右に16、下に1つ移動したAH4セルに貼り付け、それを繰り返す…といった感じです。

複雑な処理ですみません、もし可能であれば…よろしくお願い致しますm(__)m


1 ● Z1000S
●2500ポイント ベストアンサー

これでどうでしょう?

注意点
1.SOURCE_FILE_PATHのパスは、ご使用の環境に合わせて修正してから実行して下さい。
2.copyFirstItemsSubValue実行の際は、ブックBは閉じておいていただいた方がいいです。最終段階で、ブックBを保存せずに閉じるようにしてあります。
詳細は省きますが、他にも弊害が出る場合がありえますので。

'---------- 自ワークシート関連 ----------
Private Const KEY_ITEM_SHEET_NAME As String = "Sheet1"

'検索基準キーとなるデータ列(R列)
Private Const KEY_ITEM_COL As Long = 18

'基準セルから書き込みするセルへのオフセット
Private Const COL_OFFSET_DEST_CELL As Long = 16
Private Const ROW_OFFSET_DEST_CELL As Long = 1


'---------- 参照先ワークシート関連 ----------
'参照するブックのフルパス
Private Const SOURCE_FILE_PATH As String = "C:\Datas\ブックB.xlsx"

Private Const SOURCE_SHEET_NAME As String = "Sheet1"

'参照する列(B列)
Private Const SOURCE_COL As Long = 2

'基準セルから読み込みするセルへのオフセット
Private Const COL_OFFSET_SRC_CELL As Long = 15
Private Const ROW_OFFSET_SRC_CELL As Long = 1


Public Sub copyFirstItemsSubValue()

 Dim wbSrc As Workbook
 Dim wsSrc As Worksheet
 Dim wsOwn As Worksheet
 Dim lEndRow As Long
 Dim lCurrentRow As Long
 Dim sKeyValue As String
 Dim bExistsTarget As Boolean
 Dim sTargetValue As String

 Dim dicKeyValue As New Dictionary

 On Error GoTo PostProcessing

  '参照先ワークシートの取得
 Set wbSrc = Workbooks.Open(SOURCE_FILE_PATH, ReadOnly:=True)
 Set wsSrc = wbSrc.Worksheets(SOURCE_SHEET_NAME)

  '出力先ワークシートの取得
 Set wsOwn = ThisWorkbook.Worksheets(KEY_ITEM_SHEET_NAME)

  'キーデータ列の最終行取得
 lEndRow = wsOwn.Cells(wsOwn.Rows.Count, KEY_ITEM_COL).End(xlUp).Row

 With wsOwn
 For lCurrentRow = 1 To lEndRow
  'キーの値を取得
 sKeyValue = .Cells(lCurrentRow, KEY_ITEM_COL).Value

 If sKeyValue <> "" Then
 If dicKeyValue.Exists(sKeyValue) = False Then
  '未出現のキーなら処理する
 dicKeyValue.Add sKeyValue, 0

 bExistsTarget = getTargetValue(wsSrc, sKeyValue, sTargetValue)

 If bExistsTarget Then
 .Cells(lCurrentRow, KEY_ITEM_COL).Offset(ROW_OFFSET_DEST_CELL, COL_OFFSET_DEST_CELL).Value = sTargetValue
 Else
 Call MsgBox(sKeyValue & "が参照先に見つかりません。", vbInformation + vbOKOnly, "Not Found.")

 Debug.Print sKeyValue & " Not Found."
 End If
 End If
 End If
 Next lCurrentRow
 End With

PostProcessing:
 If Err.Number <> 0 Then
 Call MsgBox(CStr(Err.Number) & ":" & Err.Description, vbCritical + vbOKOnly, "エラー")
 End If

 Set wsOwn = Nothing

 If Not wbSrc Is Nothing Then
 If Not wsSrc Is Nothing Then
 Set wsSrc = Nothing
 End If

 wbSrc.Close SaveChanges:=False

 Set wbSrc = Nothing
 End If

 Set dicKeyValue = Nothing

 Debug.Print "Done."

End Sub

Private Function getTargetValue(ByRef ws As Worksheet, ByVal sKeyValue As String, ByRef sTarget As String) As Boolean

 Dim lHeaderRow As Long
 Dim lEndRow As Long
 Dim r As Range
 Dim lFirstRow As Long

 getTargetValue = False

 sTarget = ""

 With ws
  'オートフィルタの設定状態
 If .AutoFilterMode = True Then
  'オートフィルタが設定済みなら、一旦解除
 .AutoFilter.Range.AutoFilter
 End If

  'オートフィルタのヘッダとなるダミー行を挿入
 .Rows(1).Insert
 lHeaderRow = 1
 .Cells(lHeaderRow, SOURCE_COL).Value = "DummyHeader"

  '終了行
 lEndRow = .Cells(.Rows.Count, SOURCE_COL).End(xlUp).Row

  '指定キーと一致する行を抽出
 With .Range(.Cells(1, SOURCE_COL), .Cells(lEndRow, SOURCE_COL))
  'オートフィルタ実行
 .AutoFilter Field:=1, Criteria1:=sKeyValue

 lFirstRow = ws.Rows.Count + 1

 For Each r In .SpecialCells(xlCellTypeVisible)
 If r.Row > lHeaderRow Then
 If lFirstRow > r.Row Then
 lFirstRow = r.Row
 End If
 End If
 Next r

 If lFirstRow <= ws.Rows.Count Then
 sTarget = ws.Cells(lFirstRow, SOURCE_COL).Offset(ROW_OFFSET_SRC_CELL, COL_OFFSET_SRC_CELL).Value

 getTargetValue = True
 End If

  'オートフィルタ解除
 .AutoFilter
 End With

 .Rows(1).Delete
 End With

End Function

Z1000Sさんのコメント
追記 Microsoft Scripting Runtime 参照設定して下さい。

moon-fonduさんのコメント
Z1000Sさんありがとうございます! Excelの標準モジュールで実行してみたのですが。 ユーザー定義型は定義されていません。http://f.hatena.ne.jp/moon-fondu/20180410231808 というエラーが出てきてしまいまして(^^; Microsoft Scripting Runtime?の参照設定?というのをすればよいのでしょうか?

Z1000Sさんのコメント
VBEの画面で、メニューの 「ツール」-「参照設定」 をクリックし、出てきた画面から "Microsoft Scripting Runtime"を見つけて、チェックを付け、 「OK」をクリックして下さい。 その後、再度実行してみて下さい。

Z1000Sさんのコメント
遅すぎて、使い物になりませんね。 とりあえず、改良版です。 >|vb| '参照設定:Microsoft Scripting Runtime '---------- 自ワークシート関連 ---------- Private Const KEY_ITEM_SHEET_NAME As String = "Sheet1" '検索基準キーとなるデータ列(R列) Private Const KEY_ITEM_COL As Long = 18 '基準セルから書き込みするセルへのオフセット Private Const COL_OFFSET_DEST_CELL As Long = 16 Private Const ROW_OFFSET_DEST_CELL As Long = 1 '---------- 参照先ワークシート関連 ---------- '参照するブックのフルパス Private Const SOURCE_FILE_PATH As String = "C:\Datas\ブックB.xlsx" Private Const SOURCE_SHEET_NAME As String = "Sheet1" '参照する列(B列) Private Const SOURCE_COL As Long = 2 '基準セルから読み込みするセルへのオフセット Private Const COL_OFFSET_SRC_CELL As Long = 15 Private Const ROW_OFFSET_SRC_CELL As Long = 1 Public Sub copyFirstItemsSubValue改() Dim wbSrc As Workbook Dim wsSrc As Worksheet Dim wsOwn As Worksheet Dim lEndRow As Long Dim lCurrentRow As Long Dim sKeyValue As String Dim bExistsTarget As Boolean Dim sTargetValue As String Dim dicKeyValue As New Dictionary Dim dicSrcValue As New Dictionary Application.ScreenUpdating = False On Error GoTo PostProcessing '参照先ワークシートの取得 Set wbSrc = Workbooks.Open(SOURCE_FILE_PATH, ReadOnly:=True) Set wsSrc = wbSrc.Worksheets(SOURCE_SHEET_NAME) With wsSrc 'データ列の最終行取得 lEndRow = .Cells(.Rows.Count, SOURCE_COL).End(xlUp).Row For lCurrentRow = 1 To lEndRow sTargetValue = .Cells(lCurrentRow, SOURCE_COL).Value If sTargetValue <> "" Then If dicSrcValue.Exists(sTargetValue) = False Then '未出現のキーなら処理する dicSrcValue.Add sTargetValue, lCurrentRow End If End If Next lCurrentRow End With '出力先ワークシートの取得 Set wsOwn = ThisWorkbook.Worksheets(KEY_ITEM_SHEET_NAME) 'キーデータ列の最終行取得 lEndRow = wsOwn.Cells(wsOwn.Rows.Count, KEY_ITEM_COL).End(xlUp).Row With wsOwn For lCurrentRow = 1 To lEndRow 'キーの値を取得 sKeyValue = .Cells(lCurrentRow, KEY_ITEM_COL).Value If sKeyValue <> "" Then If dicKeyValue.Exists(sKeyValue) = False Then '未出現のキーなら処理する dicKeyValue.Add sKeyValue, 0 If dicSrcValue.Exists(sKeyValue) Then .Cells(lCurrentRow, KEY_ITEM_COL).Offset(ROW_OFFSET_DEST_CELL, COL_OFFSET_DEST_CELL).Value _ = wsSrc.Cells(dicSrcValue.Item(sKeyValue), SOURCE_COL).Offset(ROW_OFFSET_SRC_CELL, COL_OFFSET_SRC_CELL).Value End If End If End If Next lCurrentRow End With PostProcessing: If Err.Number <> 0 Then Call MsgBox(CStr(Err.Number) & ":" & Err.Description, vbCritical + vbOKOnly, "エラー") End If Set wsOwn = Nothing If Not wbSrc Is Nothing Then If Not wsSrc Is Nothing Then Set wsSrc = Nothing End If wbSrc.Close SaveChanges:=False Set wbSrc = Nothing End If Set dicKeyValue = Nothing Set dicSrcValue = Nothing Application.ScreenUpdating = True Debug.Print "Done." End Sub ||<

moon-fonduさんのコメント
すごいです、Z1000Sさんのご提示の通りMicrosoft Scripting Runtimeにチェックを入れると動きまして。 改良版で試してみましたら、1秒かかったのかどうかというほどの速さで、6万行ほどのデータが変換されました! ありがとうございました(^^♪

Z1000Sさんのコメント
ベストアンサーありがとうございます。 無事(?)処理が出来たようで良かったです。 改めて見てみると、色々と無駄なことをやっていて、まだ改良の余地があるんですが・・・ まあ、今回はこれで終了ということで。 ありがとうございました。
関連質問

●質問をもっと探す●



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