Sub test2() Dim Aファイル As String Dim Bファイル As String Dim Cファイル As String Dim wb_A As Workbook Dim wb_B As Workbook Dim wb_C As Workbook Dim searchResult() As Variant Dim sourceCol As Integer Aファイル = "C:\テスト\Aファイル.xlsx" Bファイル = "C:\テスト\Bファイル.xlsx" Cファイル = "C:\テスト\Cファイル.xlsx" ' ①Aファイルをマスタとして読み取る Dim masterSheet As Worksheet Set wb_A = Workbooks.Open(Aファイル) Set masterSheet = wb_A.Sheets("マスタ") Dim masterDict As Object ' マスタのデータを格納する辞書 Set masterDict = CreateObject("Scripting.Dictionary") Dim i As Long For i = 2 To masterSheet.Cells(Rows.Count, 1).End(xlUp).row Dim keyword As String keyword = masterSheet.Cells(i, 1).value Dim productName As String productName = masterSheet.Cells(i, 2).value If Not masterDict.Exists(keyword) Then masterDict.Add keyword, productName End If Next i ' ②Bファイルを読み込んでCファイルに転記する Dim sourceSheet As Worksheet Set wb_B = Workbooks.Open(Bファイル) Set sourceSheet = wb_B.Sheets("注文書作成") Dim destSheet As Worksheet Set wb_C = Workbooks.Open(Cファイル) Set destSheet = wb_C.Sheets("注文書作成") Dim destRow As Long destRow = 2 ' Cファイルのデータを書き込む行を指定する変数 Dim lastRow As Long lastRow = sourceSheet.Cells(Rows.Count, "B").End(xlUp).row Dim j As Long For j = 2 To lastRow ' 2行目から最終行まで繰り返す Dim emptyFlag As Boolean '空判定用 Dim quantity As Variant '数量格納用 Dim amount As Variant '金額格納用 '初期設定 emptyFlag = False searchResult = fncGetCellAddress(sourceSheet, "1", "数量", "完全一致") sourceCol = searchResult(1) quantity = sourceSheet.Cells(j, sourceCol) 'quantity = sourceSheet.Cells(j, "C").value searchResult = fncGetCellAddress(sourceSheet, 1, "金額", "完全一致") sourceCol = searchResult(1) amount = sourceSheet.Cells(j, sourceCol) 'amount = sourceSheet.Cells(j, "D").value '空反映(体と数値判定がTrueになってしまうので) If IsEmpty(quantity) Or IsEmpty(amount) Then emptyFlag = True End If If IsNumeric(quantity) And IsNumeric(amount) And emptyFlag = False Then ' 「数量」の列の値が数値かつ「金額」の列の値が数値の場合 Dim keywordToLookup As String Dim lastColumn As Long Dim k As Integer Dim ItemName As String '項目名 Dim posVal As Variant Dim destCol As Long lastColumn = fncGetLastColumn(sourceSheet, 1) '列のくりかえし For k = 1 To lastColumn ItemName = sourceSheet.Cells(1, k) posVal = sourceSheet.Cells(j, k) '項目名あるか? If ItemName <> "" And posVal <> "" Then searchResult = fncGetCellAddress(destSheet, "全範囲", ItemName, "完全一致") destCol = searchResult(1) ' keywordToLookup = sourceSheet.Cells(j, i).value keywordToLookup = posVal If ItemName = "品名" And masterDict.Exists(keywordToLookup) Then ' マスタにキーワードが存在する場合 posVal = masterDict(keywordToLookup) ' マスタから商品名を取得する destSheet.Cells(destRow, destCol).value = posVal ElseIf posVal <> "" Then destSheet.Cells(destRow, destCol).value = posVal End If End If Next k destRow = destRow + 1 ' 次の行に書き込むために行数をインクリメントする End If Next j End Sub Function fncGetCellAddress(sheet As Worksheet, searchRangeRow As Variant, searchValue As String, matchType As String) As Variant '------------------------------------------------------------- ' 機能:指定した文字列でワークシートを検索し、合致した値の入っているセルアドレスを返す ' ' 引数1:検索対象のワークシートオブジェクト ' 引数2:検索対象行の行番号(全シートの場合は「全範囲」)と入れる ' 引数3:検索対象の文言' ' 引数4:完全一致か部分一致か指定する("完全一致" または "部分一致") ' ' 戻り値:検索結果のセルアドレスの行番号と列番号を配列で返す '------------------------------------------------------------- Dim searchRange As Range If searchRangeRow = "全範囲" Then Set searchRange = sheet.Cells Else Set searchRange = sheet.Rows(searchRangeRow) End If Dim foundCell As Range Select Case matchType Case "完全一致" Set foundCell = searchRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole) Case "部分一致" Set foundCell = searchRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlPart) End Select If foundCell Is Nothing Then fncGetCellAddress = Null Else fncGetCellAddress = Array(foundCell.row, foundCell.Column) End If End Function Function fncGetLastColumn(ws As Worksheet, row As Integer) As Long '------------------------------------------------------------- '機能: 指定されたワークシートの指定された行の最終列数を取得する。 '引数1: ws 対象のワークシートオブジェクト '引数2: row 対象の行(integer型) '------------------------------------------------------------- fncGetLastColumn = ws.Cells(row, ws.Columns.Count).End(xlToLeft).Column End Function
Option Explicit Sub try() Dim myDic As Object Set myDic = fncDictionary() Dim i As Long Dim j As Long Dim targetRange As Variant Dim str As String Dim str_key As String 'バリアント型配列にシート1の編集対象列とkeyとなる列を格納 Sheets(1).Activate targetRange = Sheets(1).Range(Cells(2, 1), Cells(5, 2)) '------------------------------------------------------------ '配列にkeyに該当する値を格納 Sheets(1).Activate For i = 2 To 5 str_key = Cells(i, 2) If myDic.Exists(str_key) Then 'Cells(i, 1) = myDic.Item(str_key) targetRange(i - 1, 1) = myDic.Item(str_key) End If Next '取得した値をシート1のA列に貼り付け Sheets(1).Range(Cells(2, 1), Cells(5, 1)) = targetRange End Sub
Function fncDictionary() As Object '------------------------------------------------------------ 'Dictionaryオブジェクトの宣言 Dim myDic As Object Set myDic = CreateObject("Scripting.Dictionary") '------------------------------------------------------------ Dim i As Long Dim str_key As String Dim int_Val As Integer 'Dictionaryオブジェクトの初期化、要素の追加 Sheets(2).Activate For i = 3 To 6 str_key = Cells(i, 2) int_Val = Cells(i, 3) myDic.Add str_key, int_Val Next Debug.Print myDic.Exists("鈴木") Debug.Print myDic.Item("鈴木") Set fncDictionary = myDic '------------------------------------------------------------ Dim str As String 'バリアント型配列を宣言 Dim Keys() As Variant 'バリアント型配列にディクショナリのキーを格納 Keys = myDic.Keys '------------------------------------------------------------ 'Dictionaryオブジェクトの要素の参照 ' For i = 0 To myDic.Count - 1 ' str = str & Keys(i) & " : " & myDic.Item(Keys(i)) & vbCrLf ' Next i ' Debug.Print myDic.Exists("鈴木") ' MsgBox str, vbInformation End Function