[巨集VBA]初心者學習心得04:CollapseGroup收合折疊群組,ExpandGroup打開群組,設定某欄位小數點5位,設定某欄位千分號comma,刪除空白資料列,刪除某欄位
CollapseGroup收合群組,ExpandGroup打開群組:
Sub CollapseGroup()
ActiveSheet.Outline.ShowLevels ColumnLevels:=1
End Sub
Sub ExpandGroup()
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
End Sub
設定某欄位小數點5位:
Sub aaa()
Dim sheetName As String
sheetName = "ExportShipPlan"
設定小數點幾位 sheetName, "Unit Price", 5
End Sub
Sub 設定小數點幾位(sheetName As String, columnName As String, numberOfDigits As Integer)
'設定欄位格式小數點幾位
Dim FoundFloatingNumber As Range
'Unit Price小數點五位
Set FoundFloatingNumber = Sheets(sheetName).Rows("1:1").Find(columnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'把這個欄位的value重新給一次,確保萬一不會出錯
'Sheets(sheetName).Columns(FoundFloatingNumber.Column).Select
'Selection.Value = Selection.Value
Dim numberFormat As String
numberFormat = "0."
numberFormat = numberFormat & Replace(Space(numberOfDigits), " ", "0")
Sheets(sheetName).Columns(FoundFloatingNumber.Column).numberFormat = numberFormat
End Sub
執行前:
執行後:
設定某欄位千分號comma:
Sub aaa()
Dim sheetName As String
sheetName = "ExportShipPlan"
設定千分號comma sheetName, "Ordered Qty"
End Sub
Sub 設定千分號comma(sheetName As String, columnName As String)
Dim FoundNumber As Range
'Unit Price小數點五位
Set FoundNumber = Sheets(sheetName).Rows("1:1").Find(columnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
'把這個欄位的value重新給一次,確保萬一不會出錯
Sheets(sheetName).Columns(FoundNumber.Column).Select
Selection.Value = Selection.Value
'千分號+小數點的話,格式設定成這樣
Sheets(sheetName).Columns(FoundNumber.Column).numberFormat = "#,##0.00"
'千分號且不要小數點話,格式設定成這樣
'Sheets(sheetName).Columns(FoundNumber.Column).numberFormat = "#,##0"
End Sub
執行前:
執行後:
刪除空白資料列: 經測試可刪除一百萬筆也沒問題
Option Explicit
Sub DeleteBlankRowTest()
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
'刪除空白的row, 避免結果有十幾萬個row
wkbSource.Activate
wsSource.Activate
DeleteBlankRowsUnderData wsSource
DeleteBlankRowsInData wsSource
'初始化selection,可作可不做
Cells(2, 1).Select
'開啟畫面上的資料的更新
Application.ScreenUpdating = True
MsgBox "作業順利完成!"
End Sub
'刪除資料 下面 的空白的列
Sub DeleteBlankRowsUnderData(ws As Worksheet)
Dim longCellLastRow As Long
'填入最不會缺漏資料的欄位,這邊是Sales Price
longCellLastRow = GetLastRowByColumnName(ws, "Sales Price")
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
'刪除資料 裡面 的空白的列
Sub DeleteBlankRowsInData(ws As Worksheet)
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.UsedRange
rows = r.rows.Count
For i = rows To 2 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
'取得最後一列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
'尋找某個欄位
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
完整範例下載:
https://drive.google.com/drive/folders/1IUOMw4zg8U1_W8jZpZb3Rt8xKZg0TDLr?usp=sharing
刪除某欄位
Sub DeleteColumn()
'開啟來源檔案
Dim wkbSource As Workbook
Dim strSourceFileToOpen As String
strSourceFileToOpen = ""
'透過dialog視窗取得檔案名稱
strSourceFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 MPS BILLING 的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strSourceFileToOpen = "False" Then
MsgBox "選取 MPS BILLING 的檔案失敗!.", 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)
'source檔案找到 對照值 的欄位
'關掉畫面上的資料的更新:
'執行巨集之前,先把畫面更新關掉,可以比較快速跑完巨集,不過資料量不大
'的時候,也沒必要就是了,記得程式碼的最後要把他再打開
Application.ScreenUpdating = False
'刪除 productno 欄位
Columns(FindColumn(wsSource, "productno").Column).EntireColumn.Delete
Application.ScreenUpdating = True
MsgBox "刪除欄位成功!"
End Sub
'尋找某個欄位
Function FindColumn(ws As Worksheet, strColumnName As String) As Range
Dim FoundColumn As Range
'Set FoundColumn = ws.Rows("1:1").Find(strColumnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Set FindColumn = ws.Rows("1:1").Find(strColumnName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
End Function
完整範例下載:
https://drive.google.com/drive/folders/1MRB5WXLb5PmigEB8aj8ENhtM868U2c7v?usp=sharing
參考資料:
Using VBA Macro to format a column into Comma Style - www.mrexcel.com
https://www.mrexcel.com/forum/excel-questions/249185-using-vba-macro-format-column-into-comma-style.html
Use of .NumberFormat to Format Decimal Places in Excel VBA
https://stackoverflow.com/questions/36878519/use-of-numberformat-to-format-decimal-places-in-excel-vba
Excel VBA: Expand or Collapse All Groups - JC Speaking
http://jamiche.blogspot.com/2014/03/excel-vba-expand-or-collapse-all-groups.html