[巨集VBA]初心者學習心得01:排序欄位資料,排序欄位資料(含date,通用格式),欄位順序對調或排序,新增sheet,宣告陣列,for迴圈,設定某欄位Date年月日格式,設定某欄位公式,設定某欄位vlookup公式,尋找某個欄位
排序欄位資料:
'所有變數都必須宣告之後才可使用
Option Explicit
Sub Sort_Data()
Dim wkbSource As Workbook
Dim strSourceFileToOpen As String
strSourceFileToOpen = ""
'透過dialog視窗取得檔案名稱
strSourceFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 要排序資料 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strSourceFileToOpen = "False" Then
MsgBox "選取 要排序資料 的檔案失敗!.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbSource = Workbooks.Open(strSourceFileToOpen)
wkbSource.Activate
End If
Dim intActiveSheetNoInSourceFile As Integer
intActiveSheetNoInSourceFile = 1
Dim wsSource As Worksheet
Set wsSource = wkbSource.Sheets(intActiveSheetNoInSourceFile)
'關掉畫面上的資料的更新:
Application.ScreenUpdating = False
'排序Invoice Date, Delivey Address, Invoice #, Ship From Location
'這4個欄位的range先找出來
Dim FoundSortColumn1 As Range
Set FoundSortColumn1 = FindColumn(wsSource, "Invoice Date")
Dim FoundSortColumn2 As Range
Set FoundSortColumn2 = FindColumn(wsSource, "Delivery Address")
Dim FoundSortColumn3 As Range
Set FoundSortColumn3 = FindColumn(wsSource, "Invoice #")
Dim FoundSortColumn4 As Range
Set FoundSortColumn4 = FindColumn(wsSource, "Ship From Location")
Dim FoundSortColumn5 As Range
Set FoundSortColumn5 = FindColumn(wsSource, "Invoice Item")
'所有排序欄位都需要重新給值一次,不然使用排序功能的話會有問題
'欄位格式若是通用格式,須轉為文字格式,不然排序也會有問題
'日期資料也需要轉成正確的日期格式
'第一步先重新給值
wsSource.Columns(FoundSortColumn1.Column).Select
Selection.Value = Selection.Value
wsSource.Columns(FoundSortColumn2.Column).Select
Selection.Value = Selection.Value
wsSource.Columns(FoundSortColumn3.Column).Select
Selection.Value = Selection.Value
wsSource.Columns(FoundSortColumn4.Column).Select
Selection.Value = Selection.Value
wsSource.Columns(FoundSortColumn5.Column).Select
Selection.Value = Selection.Value
'第二步把通用格式的欄位轉成文字
'還有日期的資料要設定為正確的日期格式
wsSource.Columns(FoundSortColumn1.Column).Select
Selection.Value = Selection.Value
wsSource.Columns(FoundSortColumn1.Column).numberFormat = "yyyy/m/d"
wsSource.Columns(FoundSortColumn2.Column).numberFormat = "@" '設定為文字格式
wsSource.Columns(FoundSortColumn3.Column).numberFormat = "@"
wsSource.Columns(FoundSortColumn4.Column).numberFormat = "@"
wsSource.Columns(FoundSortColumn5.Column).numberFormat = "@"
'第三步就正式開始排序
'取得所有欄位的數量
Dim longLastColumnOfSourceFile As Long
longLastColumnOfSourceFile = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
'取得的資料總筆數(用最不會有空資料的欄位去取,這邊是用Invoice Date)
Dim longLastRowOfSourceFile As Long
longLastRowOfSourceFile = GetLastRowByColumnName(wsSource, "Invoice Date")
With ActiveSheet.Sort
'先清除舊的排序
.SortFields.Clear
'要排序的第一個欄位, 要排序A欄位的話,就寫A1
'Order:xlAscending表示排序遞增,xlDecending表示排序遞減
.SortFields.Add Key:=wsSource.Range(Col_Letter(FoundSortColumn1.Column) & "1"), Order:=xlAscending
'要排序的第2個欄位
.SortFields.Add Key:=wsSource.Range(Col_Letter(FoundSortColumn2.Column) & "1"), Order:=xlAscending
'要排序的第3個欄位
.SortFields.Add Key:=wsSource.Range(Col_Letter(FoundSortColumn3.Column) & "1"), Order:=xlAscending
'要排序的第4個欄位
.SortFields.Add Key:=wsSource.Range(Col_Letter(FoundSortColumn4.Column) & "1"), Order:=xlAscending
'要排序的第5個欄位
.SortFields.Add Key:=wsSource.Range(Col_Letter(FoundSortColumn5.Column) & "1"), Order:=xlAscending
.SetRange wsSource.Range("A1:" & Col_Letter(longLastColumnOfSourceFile) & longLastRowOfSourceFile)
'資料是否包含標頭
.Header = xlYes
.Apply
End With
'刪除空白的row, 避免結果有十幾萬個row
wkbSource.Activate
wsSource.Activate
DeleteBlankRows wsSource
'初始化selection,可作可不做
Cells(2, 1).Select
'開啟畫面上的資料的更新
Application.ScreenUpdating = True
MsgBox "作業順利完成!"
End Sub
'刪除空白的列
Sub DeleteBlankRows(ws As Worksheet)
Dim longCellLastRow As Long
longCellLastRow = GetLastRowByColumnName(ws, "Invoice Date")
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.UsedRange
rows = r.rows.Count
For i = rows To (longCellLastRow + 10) Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
'尋找某個欄位
Function FindColumn(ws As Worksheet, strColumnName As String) As Range
Dim FoundColumn As Range
Set FindColumn = ws.rows("1:1").Find(strColumnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
End Function
'取得最後一列lastrow
Function GetLastRowByRange(ws As Worksheet, rangeColumn As Range) As Long
Dim longLastRow As Long
longLastRow = ws.Cells(rows.Count, rangeColumn.Column).End(xlUp).Row
GetLastRowByRange = longLastRow
End Function
'取得最後一列lastrow
Function GetLastRowByColumnName(ws As Worksheet, strColumnName As String) As Long
Dim longLastRow As Long
longLastRow = ws.Cells(rows.Count, FindColumn(ws, strColumnName).Column).End(xlUp).Row
GetLastRowByColumnName = longLastRow
End Function
'轉換column index為英文letter(支援一百個欄位喔!)
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
完整範例下載:
https://drive.google.com/drive/folders/1RttGef67mjaikoo6Tue0ff5hMDy1kNQ3?usp=sharing
欄位順序對調或排序:
Sub Reorder_Columns()
Dim ColumnOrder As Variant, ndx As Integer
Dim Found As Range, counter As Integer
ColumnOrder = Array("Header 1", "Header 2", "Header 3", "Header 4", "Header 5", "Header 6")
counter = 1
'關掉畫面上的資料的更新:
'執行巨集之前,先把畫面更新關掉,可以比較快速跑完巨集,不過資料量不大
'的時候,也沒必要就是了,記得程式碼的最後要把他再打開
Application.ScreenUpdating = False
For ndx = LBound(ColumnOrder) To UBound(ColumnOrder)
'從左上角Rows("1:1")開始尋找,找字串ColumnOrder(ndx),找儲存格的數值符合的LookIn:=xlValues
'一字不漏比對value相同LookAt:=xlWhole,一個column一個column的順序去找SearchOrder:=xlByColumns
'找的方向是下一個SearchDirection:=xlNext,大小寫不用完全相符合MatchCase:=False
Set Found = Rows("1:1").Find(ColumnOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Found Is Nothing Then
If Found.Column <> counter Then
'整個column剪下之後
Found.EntireColumn.Cut
'剪下的整個column依序insert到第1個Column、第2個Column………的位置
'被人家卡位排擠的,就自動往右移動Shift:=xlToRight
Columns(counter).Insert Shift:=xlToRight
'清空記憶體裡面的內容,以免效能越來越差
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next ndx
'開啟畫面上的資料的更新
Application.ScreenUpdating = True
End Sub
欄位順序對調之前:
Header 6 | Header 2 | Header 1 | Header 4 | Header 5 | Header 3 |
---|---|---|---|---|---|
3645 | 3434 | A | 6565 | 6543 | 5653 |
564 | 3413 | B | 563 | 5634 | 436 |
466 | 5654 | C | 56356 | 56663 | 3566 |
執行巨集之後,成功將欄位順序對調:
Header 1 | Header 2 | Header 3 | Header 4 | Header 5 | Header 6 |
---|---|---|---|---|---|
A | 3434 | 5653 | 6565 | 6543 | 3645 |
B | 3413 | 436 | 563 | 5634 | 564 |
C | 5654 | 3566 | 56356 | 56663 | 466 |
欄位順序對調的程式碼中,有些參數例如LookIn、LookAt、SearchDirection……等等,都還有其他設定參數,要更改參數設定時請參考下方(資料來自微軟官方):
新增sheet:
Sub 新增sheet()
Dim fname As String
fname = ActiveSheet.Name
newnameBefore = Left(fname, 5) '從當前工作表獲取名稱前五個字
newnameAfter = Right(fname, 1) '從當前工作表獲取名稱最後一字
newnameAfter = newnameAfter + 1 '將newnameAfter+1,以避免新工作表名稱重複
'MsgBox newnameBefore & newnameAfter
Sheets.Add(After:=ActiveSheet).Name = newnameBefore & newnameAfter
End Sub
新增sheet執行之前:
新增sheet執行後:
新增1~多個欄位:
Dim InsertColumns As Variant
InsertColumns = Array("Grade", "Customer", "Sales", "Pull In、Push Out(依Request Date)", "HUB", _
"AIT P/N", "R", "Unit Price(NTD)", "Ordered Qty(K)", "Ordered Amt(K/NTD)", "Ordered Amt(K/USD)", _
"本月已開發票QTY(K)", "月FCST", "月FCST", "月FCST", "月FCST", "月FCST", "月FCST", "BKG")
For i = LBound(InsertColumns) To UBound(InsertColumns)
'Sheet1.Columns("A:A").Insert Shift:=xlToRight
Sheets(sheetName).Columns("A:A").Insert Shift:=xlToRight
Sheets(sheetName).Cells(1, 1) = InsertColumns(i)
Next
新增一個欄位執行前:
111 | 444 | 777 |
---|---|---|
222 | 55 | 888 |
333 | 666 | 999 |
新增一個欄位執行後: table.tableizer-table { font-size: 12px; border: 1px solid #CCC; font-family: Arial, Helvetica, sans-serif; } .tableizer-table td { padding: 4px; margin: 3px; border: 1px solid #CCC; } .tableizer-table th { background-color: #104E8B; color: #FFF; font-weight: bold; }
111 | 444 | 777 | |
---|---|---|---|
222 | 55 | 888 | |
333 | 666 | 999 |
宣告陣列以及使用for迴圈:
注意!VBA的語法跟現在高階語言VB的寫法不同,別把他當成visual studio 2017來寫拉! XD
'想使用陣列array需要先宣告一個Variant
Dim InsertColumns As Variant
InsertColumns = Array("Grade", "Customer", "Sales", "Pull In、Push Out(依Request Date)", "HUB", _
"AIT P/N", "Rate", "Unit Price(NTD)", "Ordered Qty(K)", "Ordered Amt(K/NTD)", "Ordered Amt(K/USD)", _
"本月已開發票QTY(K)", "月FCST", "月FCST", "月FCST", "月FCST", "月FCST", "月FCST", "BKG")
'要用for迴圈需配合LBound與UBound
'不要用高階語言的寫法For i as Integer = 0 To InsertColumns.Length - 1的寫法阿 XD
'compile階段就會出錯了
For i = LBound(InsertColumns) To UBound(InsertColumns)
Sheet1.Columns("A:A").Insert Shift:=xlToRight
Cells(1, 1) = InsertColumns(i)
Next
設定某欄位Date年月日格式:
Dim FoundDate As Range
'找出某某欄位
Set FoundDate = Sheets(sheetName).Rows("1:1").Find("Pull In、Push Out(依Request Date)", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'把這個欄位的value重新給一次,才能轉成date型態,這是微軟的bug
'Sheets(sheetName).Columns(Chr(FoundDate.Column + 64)).Select
Sheets(sheetName).Columns(FoundDate.Column).Select
Selection.Value = Selection.Value
Sheets(sheetName).Columns(FoundDate.Column).NumberFormat = "dd-mmm-yy"
設定某欄位Date年月日格式執行前:
設定某欄位Date年月日格式執行後:
設定某欄位公式:
'設定Ordered Amt(K/NTD)欄位的公式:
'Ordered Amt(K/NTD) = Unit Price(NTD) * Ordered Qty(K)
'找出欄位Ordered Amt(K/NTD)
Dim FoundOrderAmtKNTD As Range
Set FoundOrderAmtKNTD = Sheets(sheetName).Rows("1:1").Find("Ordered Amt(K/NTD)", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'MsgBox (FoundOrderAmtKNTD.Column)
'找出欄位:Unit Price(NTD)
Dim FoundUnitPriceNTD As Range
Set FoundUnitPriceNTD = Sheets(sheetName).Rows("1:1").Find("Unit Price(NTD)", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'MsgBox (FoundUnitPriceNTD.Column)
'找出某某欄位:Ordered Qty(K)
Dim FoundOrderedQtyK As Range
Set FoundOrderedQtyK = Sheets(sheetName).Rows("1:1").Find("Ordered Qty(K)", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'MsgBox (FoundOrderedQtyK.Column)
'設定公式$A2*$B2
'lastrow最好用欄位Schedule Ship Date去找會比較好,因為其他欄位可能沒資料
Dim FoundScheduleShipDate As Range
Set FoundScheduleShipDate = Sheets(sheetName).Rows("1:1").Find("Schedule Ship Date", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
lastrow = Sheets(sheetName).Cells(Rows.Count, FoundScheduleShipDate.Column).End(xlUp).Row
Sheets(sheetName).Range(Col_Letter(FoundOrderAmtKNTD.Column) & "2:" & Col_Letter(FoundOrderAmtKNTD.Column) & lastrow).Formula = _
"=$" & Col_Letter(FoundUnitPriceNTD.Column) & "2*$" & Col_Letter(FoundOrderedQtyK.Column) & "2"
'設定公式:字串連接
'MPS INV = Invoice Serie & Invoice No & "-" & Ship From
wsSource.Range(Col_Letter(FindColumn(wsSource, "MPS INV").Column) & "2:" & _
Col_Letter(FindColumn(wsSource, "MPS INV").Column) & GetLastRow(wsSource, FindColumn(wsSource, "$"))).Formula = _
"=CONCAT(" & Col_Letter(FindColumn(wsSource, "Invoice Serie").Column) & "2," & Col_Letter(FindColumn(wsSource, "Invoice No").Column) & _
"2,""-""" & Col_Letter(FindColumn(wsSource, "Ship From").Column) & "2"
'轉換column index為英文letter
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
設定某欄位公式執行之前:
目前的公式是Ordered Amt(K/NTD) = Unit Price(NTD) * Ordered Qty(K)
Unit Price(NTD) | Ordered Qty | Ordered Qty(K) | Ordered Amt(K/NTD) |
---|---|---|---|
3 | 45,000 | 5.0 | 15 |
1.848 | 6,000 | 6.0 | 11 |
1.848 | 63,000 | 63.0 | 116 |
6 | 8 |
設定某欄位公式執行之後:
Unit Price(NTD) | Ordered Qty | Ordered Qty(K) | Ordered Amt(K/NTD) |
---|---|---|---|
3 | 45,000 | 5.0 | 15 |
1.848 | 6,000 | 6.0 | 11 |
1.848 | 63,000 | 63.0 | 116 |
6 | 8 | 48 |
ps.要直接複製上面範例表格來測試的話,貼到Excel的時候,記得用"選擇性貼上",然後選"文字"選項就可以了!
設定某欄位vlookup公式:
'設定PO DEPT CODE公式
Dim FoundPODeptCodeTemplate As Range
Set FoundPODeptCodeTemplate = wsTemplate.Rows("1:1").Find("PO DEPT CODE", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Dim FoundMISSalesCodeTemplate As Range
Set FoundMISSalesCodeTemplate = wsTemplate.Rows("1:1").Find("MIS Sales Code", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Dim FoundMISSalesCodeMOQ As Range
Set FoundMISSalesCodeMOQ = wsMOQ.Rows("1:1").Find("MIS Sales Code", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Dim FoundPODeptCodeMOQ As Range
Set FoundPODeptCodeMOQ = wsMOQ.Rows("1:1").Find("PO DEPT CODE", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Dim fileName As String
Dim fileNameWithoutExtension As String
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
fileNameWithoutExtension = fso.GetBaseName(strMOQFileToOpen)
Dim vlookPODeptCode As String
',2,0的2表示抓出第二個欄位,2,0的0表示比對的key value需完全相同
vlookPODeptCode = "=VLOOKUP(" & Col_Letter(FoundMISSalesCodeTemplate.Column) & ":" & Col_Letter(FoundMISSalesCodeTemplate.Column) & _
",'" & Replace(strMOQFileToOpen, fileNameWithoutExtension, "[" & fileNameWithoutExtension) & _
"]MOQ'!$" & Col_Letter(FoundMISSalesCodeMOQ.Column) & ":$" & Col_Letter(FoundPODeptCodeMOQ.Column) & _
",2,0)"
wsTemplate.Range(Col_Letter(FoundPODeptCodeTemplate.Column) & "2:" & Col_Letter(FoundPODeptCodeTemplate.Column) & _
lastRow).Formula = vlookPODeptCode
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
參考資料:
Find Column and format as Date
https://stackoverflow.com/questions/9744154/find-column-and-format-as-date
VBA 將Excel insert 一列
http://www.blueshop.com.tw/board/show.asp?subcde=BRD20071025101118ARP&odr=cdt&odrtyp=0
Range.Find 方法 (Excel)
https://msdn.microsoft.com/zh-tw/vba/excel-vba/articles/range-find-method-excel
Rearrange Excel columns via Visual Basic
https://code.adonline.id.au/rearrange-columns-excel-vba/
How to Sort Data in Excel using VBA (A Step-by-Step Guide)
https://trumpexcel.com/sort-data-vba/#Understanding-the-RangeSort-Method-in-Excel-VBA