検索シートのデータとアクティブシートの重複チェック､新規シートに結果を貼り付け
このVBAコードは、アクティブ（Activesheet）なシートと別のシート（前のシート：ActiveSheet.Previous）にあるデータを比較し、重複しているデータを新しいシートに転記するものです。
＊Activesheetを選択した状態で実施
Sub 検索シートのデータとアクティブシートの重複チェック､新規シートに結果を貼り付け()
Dim c As Range
Dim v() As Variant
Dim cols As Long
Dim j As Long
Dim dic As Object
Dim newWs As Worksheet
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
' 検索シートの値を辞書に格納
With ActiveSheet.Previous
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If Not dic.Exists(c.Value) Then
dic.Add c.Value, dic.Count + 1
End If
Next
End With
With ActiveSheet
cols = .UsedRange.Cells(.UsedRange.Cells.Count).Column
ReDim v(1 To dic.Count, 1 To cols)
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If dic.Exists(c.Value) Then
i = dic(c.Value)
For j = 1 To cols
v(i, j) = c.EntireRow.Cells(j).Value
Next
dic.Remove c.Value ' 重複する値を削除
End If
Next
End With
' 新規ワークシートを作成して結果を転記
Set newWs = Worksheets.Add(After:=ActiveSheet.Next)
newWs.Name = ActiveSheet.Name & "_作成" & VBA.Format(Now(), "h時mm分ss秒")
newWs.Columns("A").Resize(, cols).ClearContents
newWs.Range("A2").Resize(dic.Count, cols).Value = v
newWs.Select
' 辞書の解放
Set dic = Nothing
MsgBox "転記完了"
End Subまず、スクリプト内で「Scripting.Dictionary」オブジェクトを作成します。これは、データを格納するための連想配列のようなものです。そして、前のシートから全体をループし、各行のA列の値をディクショナリに格納します。これにより、前のシートにある重複しない値が抽出されます。
次に、アクティブなシートをループして、各行のA列の値が前のシートのディクショナリに存在するかどうかを確認します。もしそうであれば、その行の値を配列にコピーします。このようにして、前のシートとアクティブなシートのデータが重複している場合に、アクティブなシートのデータを新しい配列に格納することができます。
最後に、新しいシートを作成し、重複しないデータのみを含む配列を新しいシートに転記します。そして、転記が完了したことを示すメッセージが表示されます。
＜ポイント＞
- 辞書の追加処理に重複チェックを追加し、重複する値を格納しないようにしています。
- 辞書から値を取り出すときに、Keys メソッドを使わずに Item メソッドを使うようにしました。
- 新規ワークシートを作成する前にエラー処理を解除し、エラーが発生した場合はそのまま処理を続けます。
- 新規ワークシートを変数に格納しておき、直接参照するようにしました。
- 結果の転記に際して、配列のサイズを調整してから値を格納するようにしました。
- 辞書を解放する処理を追加しました。
- dic(c.Value) = dic.Count + 1：その値をキー、１からの連番をデータとして辞書登録
- ReDim v(1 To dic.Count, 1 To cols) ：空白行はスケルトンにする
- もし辞書にあれば（シート２にあれば）１行分のイメージを配列に格納
- .Columns(“A”).Resize(, cols).ClearContents：最初に転記領域のクリア
シート指定／新規シート記入／マッチング／行／新規シート貼付け
このVBAコードは、指定したシートとアクティブシートの列Aの値を比較して、重複している行を新規シートにコピーするものです。
Sub 検索シートのデータとアクティブシート間､マッチングしているものを新規シートに貼り付け()
Dim c As Range
Dim v() As Variant
Dim cols As Long
Dim j As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("検索ﾃﾞｰﾀ")
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
dic(c.Value) = dic.Count + 1
Next
End With
With ActiveSheet
cols = .UsedRange.Cells(.UsedRange.Cells.Count).Column
ReDim v(1 To dic.Count, 1 To cols)
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If dic.Exists(c.Value) Then
For j = 1 To cols
v(dic(c.Value), j) = c.EntireRow.Cells(j).Value
Next
End If
Next
End With
Worksheets.Add(After:=ActiveSheet.Next).Name = ActiveSheet.Name & "_作成" & VBA.Format(Now(), "h時mm分ss秒")
With ActiveSheet
.Columns("A").Resize(, cols).ClearContents
.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Select
End With
MsgBox "転記完了"
End Subまず、Scripting.Dictionaryオブジェクトを作成し、指定したシート(“検索データ”)の列Aの値をキーとして、行数を値として格納します。これにより、指定したシートの列Aに重複する値がなくなり、一意のキーとなります。
次に、アクティブシートの列Aの値を比較して、Dictionaryオブジェクトに存在する場合は、その行の値を配列に格納します。これにより、指定したシートとアクティブシートの重複した行のみが、新規シートにコピーされます。
最後に、新規シートを作成し、配列の値を新規シートに貼り付けます。また、新規シートには、アクティブシートの名前と現在の日時を含む名前が付けられます。最後に、転記が完了した旨のメッセージが表示されます。
v(dic(c.Value), j) = c.EntireRow.Cells(j).Value：
・もし辞書にあれば（シート２にあれば）１行分のイメージを配列に格納
・.Columns(“A”).Resize(, cols).ClearContents：最初に転記領域のクリア
マッチング／行／ディクショナリ パターン２
このVBAコードは、2つのExcelシートを比較して、マッチングしているデータを新規シートに貼り付けるマクロです。以下、各行ごとに解説します。
Sub シート突合_行_ディクショナリ_新規シート貼り付け()
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
Set ws1 = wb1.ActiveSheet
Dim LastCol1 As Long
LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Dim wb2 As Workbook
Set wb2 = ThisWorkbook
Dim ws2 As Worksheet
Set ws2 = wb2.ActiveSheet.Next
Dim LastRow2 As Long
LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol2 As Long
LastCol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
ws1.Activate
'ファイル突合
Dim myDic As Object
Dim i As Long
Dim LastColumn1 As Long
LastColumn1 = ws1.Cells(2, Columns.Count).End(xlToLeft).Column + 1
Set myDic = CreateObject("Scripting.Dictionary")
'相手ファイル
With ws2
For i = 2 To LastRow2 + 1
DoEvents
On Error Resume Next
If Not myDic.Exists(ws2.Cells(i, 1).Value) Then
myDic.Add ws2.Cells(i, 1).Value, ws2.Cells(i, 1).Value
End If
Application.StatusBar = i - 2 & "/" & LastRow2 & " 完了"
Next i
On Error GoTo 0
End With
'このファイル
Dim LastRow1 As Long
LastRow1 = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
With ws1
For i = 2 To LastRow1 + 1
DoEvents
On Error Resume Next
If myDic.Exists(ws1.Cells(i, 1).Value) Then
ws1.Cells(i, LastColumn1).Value = myDic.Item(ws1.Cells(i, 1).Value)
End If
Application.StatusBar = i - 2 & "/" & LastRow1 & " 完了"
Next i
On Error GoTo 0
End With
myDic.RemoveAll
Set myDic = Nothing
Set wb2 = Nothing
Set ws2 = Nothing
MsgBox "完了"
End Sub1行目:Sub宣言。マクロの名前を指定します。
3-6行目：変数wb1とws1を作成し、アクティブなワークブックとアクティブなシートをそれぞれに割り当てます。
9-10行目:変数LastCol1を作成し、ws1の1行目の最後の列を取得しています。
18-20行目：変数wb2とws2を作成し、アクティブなワークブックの次のシートをそれぞれに割り当て、そのシートの最後の行と最後の列を取得しています。
25-26行目:変数myDicを作成し、Scripting.Dictionaryオブジェクトを作成しています。
29-30行目:変数LastColumn1を作成し、ws1の2行目の最後の列に1を加えたものを取得しています。
32-40行目:変数myDicを使用して、2番目のシートのデータをループし、キーとして列Aの値を使用してmyDicにデータを追加しています。
42-49行目:アクティブなワークブックのデータをループし、列Aの値を使用してmyDicからデータを取得し、2番目のシートに対応する行にコピーしてい
54-55行目:myDicをクリアします。
56-59行目:MsgBoxで処理完了のメッセージを表示します。
シート指定／新規シート記入／マッチング／行／新規シート貼付け
このVBAマクロは、アクティブなシートと「検索データ」という名前の別のシートの間で、特定のカラムに一致するデータを検索し、その一致するデータを新しいシートに貼り付けるものです。
Sub 検索シートのデータとアクティブシート間､マッチングしているものを新規シートに貼り付け()
Dim c As Range
Dim v() As Variant
Dim cols As Long
Dim j As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("検索ﾃﾞｰﾀ")
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
dic(c.Value) = dic.Count + 1
Next
End With
With ActiveSheet
cols = .UsedRange.Cells(.UsedRange.Cells.Count).Column 'シート１の列数取得 ’Dim LastCol1 As Long ’LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
ReDim v(1 To dic.Count, 1 To cols) '空白行スケルトン
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If dic.Exists(c.Value) Then 'もし辞書にあれば（シート２にあれば）１行分のイメージを配列に格納
For j = 1 To cols
v(dic(c.Value), j) = c.EntireRow.Cells(j).Value
Next
End If
Next
End With
'-----------------------------------
Worksheets.Add(After:=ActiveSheet.Next).Name = ActiveSheet.Name & "_作成" & VBA.Format(Now(), "h時mm分ss秒")
With ActiveSheet 'Sheets("Sheet2")
'最初に転記領域のクリア
.Columns("A").Resize(, cols).ClearContents
.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Select
End With
MsgBox "転記完了"
End Subまず、’CreateObject(“Scripting.Dictionary”)を使用して、データを保存するための辞書オブジェクトを作成します。この辞書オブジェクトは、検索データシートからカラムAの値を読み取り、一致するデータを検索するために使用されます。
次に、アクティブなシートから、一致するデータを検索するために、同じくカラムAの値を読み取ります。そして、’dicという辞書オブジェクトを使用して、アクティブなシートの値が検索データシートに存在するかどうかを調べます。もし辞書にあれば、その行の各列のデータを配列に格納します。最後に、配列に格納された一致するデータを新しいシートに貼り付けます。
具体的には、新しいシートを作成し、一致するデータを貼り付ける前に、新しいシートの列をクリアして、貼り付けのための領域を用意します。そして、配列からデータを取り出して、新しいシートに貼り付けます。
最後に、’MsgBoxを使用して、転記が完了したことを示すメッセージを表示します。
ディクショナリ
このVBAコードは、検索シートのデータとアクティブシートのデータをマッチングして、マッチしたものを新しいシートに転記するコードです。
Sub ディクショナリ_未検証66()
Dim c As Range
Dim v() As Variant
Dim cols As Long
Dim j As Long
Dim dic As Object
Dim k As Long
Dim baseV() As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("検索ﾃﾞｰﾀ")
'シート１の列数取得
cols = .UsedRange.Cells(.UsedRange.Cells.Count).Column
'シート1のD1からD列のデータ最終行までのセルを１つずつ取り出す
For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
'その１行のイメージを辞書に登録
dic(c.Value) = c.EntireRow.Resize(, cols).Value
Next
End With
ReDim baseV(1 To 1, 1 To cols) '空白行スケルトン
With ActiveSheet
'シート２のA1からA列のデータ最終行までのセルを１つずつ取り出す
With .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
ReDim v(1 To .Rows.Count)
For Each c In .Cells
k = k + 1
If dic.Exists(c.Value) Then 'シート１にあれば
v(k) = dic(c.Value)
Else
v(k) = baseV
End If
Next
End With
End With
Worksheets.Add(After:=ActiveSheet.Next).Name = ActiveSheet.Name & "_作成" & VBA.Format(Now(), "h時mm分ss秒")
'Worksheets.Add
'ActiveSheet.Name = "output"
'Do
'If Err.Number = 0 Then Exit Do
'Err.Clear
'Num = Num + 1
'ActiveSheet.Name = "output" & "_" & Num
'Loop
'Dim outputSheet As Worksheet
'Set outputSheet = ActiveSheet
With ActiveSheet
.Range("A2").Select
'最初に転記領域のクリア
'.Columns("A").Resize(, cols).ClearContents
.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
'Sheets("検索ﾃﾞｰﾀ").Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Select
End With
MsgBox "転記終了"
End Subまず、辞書オブジェクトを作成し、検索データシートから各行のA列の値をキーとして、その行全体のデータを辞書の値に登録します。次に、アクティブシートのA列の値をキーとして、辞書に登録されている値を取得し、v配列に格納します。辞書にキーが存在しない場合は、空白行スケルトン(baseV配列)を使用します。最後に、v配列を新しいシートに貼り付けます。
ディクショナリ２
Sub 作成2()
Const KENSAKU_CLM As Long = 2 '「転記先」シートＢ列
Const KENSAKU_ROW As Long = 4 '「転記先」シート４行目
Const MOTO_KEY_CLM As Long = 3 '「元表」シートのキー列（社名列：C列）
Const MOTO_KEY_ROW As Long = 7 '「元表」シートのキー行（項目見出し行:７行目）
Dim Sh_Moto As Worksheet '「元表」シート
Dim Sh_Tenki As Worksheet '「転記先」シート
'Dictionaryオブジェクトの宣言
Dim dicShamei As Object '元表の社名行番号ディクショナリ
Dim dicKomoku As Object '元表の項目名列番号ディクショナリ
Dim iRRow As Integer '元表シートの読込行
Dim iRCol As Integer '元表シートの読込列
Dim iWRow As Integer '転記先シートの出力行
Dim iWCol As Integer '転記先シートの出力列
Set Sh_Moto = Worksheets("元表")
Set Sh_Tenki = Worksheets("転記先")
Set dicShamei = CreateObject("Scripting.Dictionary")
Set dicKomoku = CreateObject("Scripting.Dictionary")
'【ディクショナリ作成】
'元表シートから社名のディクショナリを作成
For iRRow = 8 To Sh_Moto.Cells(8, MOTO_KEY_CLM).End(xlDown).Row
'社名をキーとして行番号をディクショナリに保管（同じ社名が複数存在した場合、後勝ちで行番号が上書きされます）
dicShamei(Sh_Moto.Cells(iRRow, "C").Value) = iRRow
Next
'元表シートから項目名のディクショナリを作成
For iRCol = 4 To Sh_Moto.Cells(MOTO_KEY_ROW, 4).End(xlToRight).Column
'項目名をキーとして列番号をディクショナリに保管
dicKomoku(Sh_Moto.Cells(7, iRCol).Value) = iRCol
Next
'【転記処理】
'転記先シートの社名ループ
For iWRow = 5 To Sh_Tenki.Cells(5, KENSAKU_CLM).End(xlDown).Row
'社名から元表の行番号を取得
If dicShamei.Item(Sh_Tenki.Cells(iWRow, KENSAKU_CLM).Value) = "" Then
'社名から行番号が取得できない場合は何もしない
Else
'元表の行番号を取得
iRRow = dicShamei.Item(Sh_Tenki.Cells(iWRow, KENSAKU_CLM).Value)
'転記先シートの項目ループ
For iWCol = 4 To Sh_Moto.Cells(KENSAKU_ROW, 4).End(xlToRight).Column
'項目名から元表の列番号を取得
If dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value) = "" Then
'項目名から列番号が取得できない場合は何もしない
Else
'元表の列番号を取得
iRCol = dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value)
'「元表」シートの取得行・取得列のセルの値を、「転記先」シートの出力行・出力列に出力する
Sh_Tenki.Cells(iWRow, iWCol).Value = Sh_Moto.Cells(iRRow, iRCol).Value
End If
Next iWCol
End If
Next iWRow
MsgBox "完了"
End Sub
コメント