兩個excel快速比對key值並撈回單一欄位值,兩個excel快速比對key值並撈回多個欄位值,整列儲存格上色,設定整列的框線
兩個excel快速比對key值並撈回單一欄位值:
wsPO, wsMOQ是兩個sheet物件，將會以key值做比對，一旦比對到資料，就會把wsMOQ的單一欄位的value複製回wsPO裡面
'開啟PO檔案
Dim wkbPO As Workbook
Dim strPOFileToOpen As String
strPOFileToOpen = ""
'透過dialog視窗取得檔案名稱
strPOFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 PO 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strPOFileToOpen = "False" Then
MsgBox "選取 PO 的檔案失敗！.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbPO = Workbooks.Open(strPOFileToOpen)
'MsgBox "開啟 PO 的檔案成功！.", vbExclamation, "成功!"
End If
'開啟MOQ檔案
Dim wkbMOQ As Workbook
Dim strMOQFileToOpen As String
strMOQFileToOpen = ""
'透過dialog視窗取得檔案名稱
strMOQFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 MOQ 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strMOQFileToOpen = "False" Then
MsgBox "選取 MOQ 的檔案失敗！.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbMOQ = Workbooks.Open(strMOQFileToOpen)
End If
Dim wsPO As Worksheet
Set wsPO = wkbPO.Worksheets(1)
If wsPO.FilterMode Then wsPO.ShowAllData
If wsPO.AutoFilterMode Then wsPO.AutoFilterMode = False
Dim wsMOQ As Worksheet
Set wsMOQ = wkbMOQ.Worksheets("MOQ")
If wsMOQ.FilterMode Then wsMOQ.ShowAllData
If wsMOQ.AutoFilterMode Then wsMOQ.AutoFilterMode = False
'找出Part#欄位
Dim FoundPartNumber As Range
Set FoundPartNumber = wsPO.Rows("1:1").Find("Part#", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'找出各個excel的最後一列
Dim lastRowPO As Long
lastRowPO = wsPO.Cells(Rows.Count, FoundPartNumber.Column).End(xlUp).Row
Dim lastRowMOQ As Long
lastRowMOQ = wsMOQ.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRowPO
'到MOQ檔案要撈回來的值
Dim MappingPOColumns1 As Variant
MappingPOColumns1 = Array("MOQ", "Dock code", "Sales code")
Dim MappingMOQColumns As Variant
MappingMOQColumns = Array("Reel_qty", "Dock Code", "Sales Code")
Dim SearchDirections1 As Variant '1:next, 2:previous
SearchDirections1 = Array(1, 1, 1)
Dim LookAts1 As Variant '1:xlWhole, 2:xlPart
LookAts1 = Array(1, 2, 1)
'到MOQ檔案要比對的key
Dim MappingPOKeys As Variant
MappingPOKeys = Array("Part#", "End Cust.", "MPS sales")
Dim MappingMOQKeys As Variant
MappingMOQKeys = Array("Device", "Sub customer", "Sales")
Dim KeySearchDirections As Variant '1:next, 2:previous
KeySearchDirections = Array(1, 1, 1)
Dim KeyLookAts As Variant '1:xlWhole, 2:xlPart
KeyLookAts = Array(2, 1, 1)
For p = LBound(MappingPOColumns1) To UBound(MappingPOColumns1)
Dim FoundPOKey As Range
Set FoundPOKey = wsPO.Rows("1:1").Find(MappingPOKeys(p), LookIn:=xlValues, LookAt:=KeyLookAts(p), SearchOrder:=xlByColumns, _
SearchDirection:=KeySearchDirections(p), MatchCase:=False)
Dim FoundMOQKey As Range
Set FoundMOQKey = wsMOQ.Rows("1:1").Find(MappingMOQKeys(p), LookIn:=xlValues, LookAt:=KeyLookAts(p), SearchOrder:=xlByColumns, _
SearchDirection:=KeySearchDirections(p), MatchCase:=False)
For q = 2 To lastRowMOQ
If LCase(wsPO.Cells(i, FoundPOKey.Column)) = LCase(wsMOQ.Cells(q, FoundMOQKey.Column)) Then
Dim FoundPOColumn1 As Range
Set FoundPOColumn1 = wsPO.Rows("1:1").Find(MappingPOColumns1(p), LookIn:=xlValues, LookAt:=LookAts1(p), SearchOrder:=xlByColumns, _
SearchDirection:=SearchDirections1(p), MatchCase:=False)
Dim FoundMOQColumn As Range
Set FoundMOQColumn = wsMOQ.Rows("1:1").Find(MappingMOQColumns(p), LookIn:=xlValues, LookAt:=LookAts1(p), SearchOrder:=xlByColumns, _
SearchDirection:=SearchDirections1(p), MatchCase:=False)
wsPO.Cells(i, FoundPOColumn1.Column) = wsMOQ.Cells(q, FoundMOQColumn.Column)
End If
Next
Next
Next
兩個excel快速比對key值並撈回大量欄位值:
wsPO, wsRFQ是兩個sheet物件，將會以key值做比對，一旦比對到資料，就會把wsRFQ的多個欄位的value複製回wsPO裡面
'開啟PO檔案
Dim wkbPO As Workbook
Dim strPOFileToOpen As String
strPOFileToOpen = ""
'透過dialog視窗取得檔案名稱
strPOFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 PO 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strPOFileToOpen = "False" Then
MsgBox "選取 PO 的檔案失敗！.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbPO = Workbooks.Open(strPOFileToOpen)
'MsgBox "開啟 PO 的檔案成功！.", vbExclamation, "成功!"
End If
'開啟RFQ檔案
Dim wkbRFQ As Workbook
Dim strRFQFileToOpen As String
strRFQFileToOpen = ""
'透過dialog視窗取得檔案名稱
strRFQFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 RFQ 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strRFQFileToOpen = "False" Then
MsgBox "選取 RFQ 的檔案失敗！.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbRFQ = Workbooks.Open(strRFQFileToOpen)
'MsgBox "開啟 RFQ 的檔案成功！.", vbExclamation, "成功!"
End If
Dim wsPO As Worksheet
Set wsPO = wkbPO.Worksheets(1)
If wsPO.FilterMode Then wsPO.ShowAllData
If wsPO.AutoFilterMode Then wsPO.AutoFilterMode = False
Dim wsRFQ As Worksheet
Set wsRFQ = wkbRFQ.Worksheets("AIT-New")
If wsRFQ.FilterMode Then wsRFQ.ShowAllData
If wsRFQ.AutoFilterMode Then wsRFQ.AutoFilterMode = False
'找出Part#欄位
Dim FoundPartNumber As Range
Set FoundPartNumber = wsPO.Rows("1:1").Find("Part#", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Dim lastRowPO As Long
lastRowPO = wsPO.Cells(Rows.Count, FoundPartNumber.Column).End(xlUp).Row
Dim lastRowRFQ As Long
lastRowRFQ = wsRFQ.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRowPO
For ii = 2 To lastRowRFQ
'到RFQ檔案對應key值之後給值
Dim compareRFQ As String
compareRFQ = wsRFQ.Cells(ii, 1)
If LCase(wsPO.Cells(i, FoundCombinePNCUS.Column)) = LCase(compareRFQ) Then
'全自動全欄位給值
Dim MappingPOColumns As Variant
MappingPOColumns = Array("序數", "RS", "COST-UP", "RFQ", "End products code", "End products", "Subcode(Sub2)", "Endcode(EC2)", "EndCust(EC2)", _
"MPS sales")
Dim MappingRFQColumns As Variant
MappingRFQColumns = Array("序數", "PRICE", "COST", "RFQNO", "End product code", "EndProduct", "Subcode", "Endcode", "EndCust", _
"MPSSales")
Dim SearchDirections As Variant '1:next, 2:previous
SearchDirections = Array(2, 1, 1, 1, 1, 1, 1, 1, 1, 1)
Dim LookAts As Variant '1:xlWhole, 2:xlPart
LookAts = Array(1, 2, 2, 1, 1, 1, 2, 2, 1, 1)
For j = LBound(MappingPOColumns) To UBound(MappingPOColumns)
Dim FoundPOColumn As Range
Set FoundPOColumn = wsPO.Rows("1:1").Find(MappingPOColumns(j), LookIn:=xlValues, LookAt:=LookAts(j), SearchOrder:=xlByColumns, _
SearchDirection:=SearchDirections(j), MatchCase:=False)
Dim FoundRFQColumn As Range
Set FoundRFQColumn = wsRFQ.Rows("1:1").Find(MappingRFQColumns(j), LookIn:=xlValues, LookAt:=LookAts(j), SearchOrder:=xlByColumns, _
SearchDirection:=SearchDirections(j), MatchCase:=False)
wsPO.Cells(i, FoundPOColumn.Column) = wsRFQ.Cells(ii, FoundRFQColumn.Column)
Next
Exit For
End If
Next
Next
整列儲存格上色:
'取得最後一列
Dim lastColumnTemplate As Long
lastColumnTemplate = wsTemplate.Cells(1, Columns.Count).End(xlToLeft).Column
Dim templateRowNo As Integer
templateRowNo = 2
wsTemplate.Range(Col_Letter(1) & templateRowNo & ":" & _
Col_Letter(lastColumnTemplate) & templateRowNo).Interior.Color = vbRed
'欄位數字轉英文
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
設定整列的框線:
'開啟 範本檔檔案
Dim wkbTemplate As Workbook
Dim strTemplateFileToOpen As String
strTemplateFileToOpen = ""
'透過dialog視窗取得檔案名稱
strTemplateFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 (MPS_POA) 的空白範本檔", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strTemplateFileToOpen = "False" Then
MsgBox "選取 範本檔 失敗！.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbTemplate = Workbooks.Open(strTemplateFileToOpen)
End If
Dim wsTemplate As Worksheet
Set wsTemplate = wkbTemplate.Worksheets(1)
If wsTemplate.FilterMode Then wsTemplate.ShowAllData
If wsTemplate.AutoFilterMode Then wsTemplate.AutoFilterMode = False
Dim lastColumnTemplate As Long '取得最後一個column
lastColumnTemplate = wsTemplate.Cells(1, Columns.Count).End(xlToLeft).Column
Dim templateRowNo As Integer
templateRowNo = 2 '第幾列請自行設定喔
'設定整列的框線
wsTemplate.Range("A" & templateRowNo & ":" & Col_Letter(lastColumnTemplate) & templateRowNo).Borders.LineStyle = xlContinuous
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
參考資料:
自己的工作經驗
