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列)に貼り付けたいのです。

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

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2018/04/09 20:52:11
  • 終了:2018/04/12 07:41:51
id:moon-fondu

前回も似たような質問 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

ベストアンサー

id:Z1000S No.1

Z1000S回答回数27ベストアンサー獲得回数202018/04/10 21:49:23

ポイント2500pt

これでどうでしょう?

注意点
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
他4件のコメントを見る
id:moon-fondu

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

2018/04/12 07:41:32
id:Z1000S

ベストアンサーありがとうございます。
無事(?)処理が出来たようで良かったです。

改めて見てみると、色々と無駄なことをやっていて、まだ改良の余地があるんですが・・・
まあ、今回はこれで終了ということで。

ありがとうございました。

2018/04/12 21:35:00

その他の回答(0件)

id:Z1000S No.1

Z1000S回答回数27ベストアンサー獲得回数202018/04/10 21:49:23ここでベストアンサー

ポイント2500pt

これでどうでしょう?

注意点
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
他4件のコメントを見る
id:moon-fondu

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

2018/04/12 07:41:32
id:Z1000S

ベストアンサーありがとうございます。
無事(?)処理が出来たようで良かったです。

改めて見てみると、色々と無駄なことをやっていて、まだ改良の余地があるんですが・・・
まあ、今回はこれで終了ということで。

ありがとうございました。

2018/04/12 21:35:00

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

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

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

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

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