kevinya

低調

2018-09-03

[巨集VBA]初心者學習心得01:排序欄位資料,排序欄位資料(含date,通用格式),欄位順序對調或排序,新增sheet,宣告陣列,for迴圈,設定某欄位Date年月日格式,設定某欄位公式,設定某欄位vlookup公式,尋找某個欄位

[巨集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 6Header 2Header 1Header 4Header 5Header 3
36453434A656565435653
5643413B5635634436
4665654C56356566633566


執行巨集之後，成功將欄位順序對調：

Header 1Header 2Header 3Header 4Header 5Header 6
A34345653656565433645
B34134365635634564
C565435665635656663466


欄位順序對調的程式碼中，有些參數例如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

新增一個欄位執行前：

111444777
22255888
333666999

新增一個欄位執行後： 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      444777
222 55888
333 666999


宣告陣列以及使用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 QtyOrdered Qty(K)Ordered Amt(K/NTD)
345,0005.015
1.8486,0006.011
1.84863,00063.0116
6 8 

​設定某欄位公式執行之後：

Unit Price(NTD)Ordered QtyOrdered Qty(K)Ordered Amt(K/NTD)
345,0005.015
1.8486,0006.011
1.84863,00063.0116
6 848

 


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

 

 

 

 

標籤雲