ray88’s diary

お仕事で困ったとき用の自分用の覚書

temp2

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