[巨集VBA]初心者學習心得03:設定欄位群組,將Column index轉換成英文letter,凍結視窗,input輸入資料,開啟檔案,取得最後一個column,所有欄位客製化置中置左置右

2018-09-24

群組語法介紹：

Sub 主程式()
    Dim FoundStart As Range
    '找出某某欄位
    Set FoundStart = Sheets("BEFORE").Rows("1:1").Find("起始Header", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    Dim FoundEnd As Range
    '找出某某欄位
    Set FoundEnd = Sheets("BEFORE").Rows("1:1").Find("結束Header", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    
    '設定群組(利用Col_Letter這個function將column index轉換成英文letter)
    Sheets("BEFORE").Columns(Col_Letter(FoundStart.Column) & ":" & Col_Letter(FoundEnd.Column)).Columns.Group
    '取消群組參考上一行，最後的Group改成Ungroup即可
End Sub

Function Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function

執行效果：

凍結視窗：
下面例子是凍結第一個Row以及凍結8個column

'這樣就會凍結第1個 Row以及ABCDEFGH column
'注意：在Application.ScreenUpdateing = False的情況下，會凍結失敗
ActiveWindow.FreezePanes = False
Range("I2").Select
ActiveWindow.FreezePanes = True

執行結果：

input輸入資料：

Dim abc As String
abc = InputBox("請輸入匯率")

開啟檔案v1：開啟workbook + worksheet

Dim wkb As Workbook

Dim strFileToOpen As String
strFileToOpen = ""
'透過dialog視窗取得檔案名稱
strFileToOpen = Application.GetOpenFilename _
(Title:="請選擇PD 102的檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
	
If strFileToOpen = "False" Then
	MsgBox "選取PD 102檔案失敗！.", vbExclamation, "Sorry!"
	Exit Sub
Else
	Set wkb = Workbooks.Open(strFileToOpen)
	Dim FoundMappingProductNo As Range
	Set FoundMappingProductNo = wkb.Sheets("AIT PN處理後").Rows("1:1").Find("Product_no (處理前)", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
	'開啟檔案之後，Activate的workbook就會變成對方了
	'要回來存取自己的workbook的時候，要再用.Activate切換回來
	'同理，如果要兩個workbook切來切去的時候，要常常.Activate不同的workbook
	ThisWorkbook.Activate
	Worksheets("BEFORE").Activate
	wkb.Activate
	Worksheets("page").Activate
	wkb.Close SaveChanges:=False
End If

執行結果：跳出一個dialog視窗讓使用者可以選擇檔案

開啟檔案v2：開啟workbook + worksheet + 展開群組 + 解除篩選

'開啟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

Dim wsPO As Worksheet
Set wsPO = wkbPO.Worksheets(1)
If wsPO.FilterMode Then wsPO.ShowAllData
If wsPO.AutoFilterMode Then wsPO.AutoFilterMode = False
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
'收合群組
'ActiveSheet.Outline.ShowLevels ColumnLevels:=1

取得最後一個column：

Dim lastColumn As Long
lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

所有欄位客製化置中置左置右：

Dim ColumnAlignLeft As Variant, ndx As Integer
Dim Found As Range
	ColumnAlignLeft = Array("Grade", "Customer", "Schedule Ship Date", "Request Date", "Ordered Date", "Ordered Date", _
	"Territory", "Pre Sch Ship Date", "Customer Name", "AIT P/N", "Product_no", "Package Type", "Currency", _
	"Order Status", "LATEST_UPDATED_FLAG", "Hold Reason", "Application Field", "Schedule Change Date", _
	"Planner Remark", "Sale Person", "Shipping Method", "SA Planner")

Application.ScreenUpdating = False
For ndx = LBound(ColumnAlignLeft) To UBound(ColumnAlignLeft)
	Set Found = Rows("1:1").Find(ColumnAlignLeft(ndx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
	If Not Found Is Nothing Then
		Dim columnEng As String
		columnEng = Col_Letter(Found.Column)
		'該欄位所有資料(包括header)置左
		Columns(columnEng & ":" & columnEng).HorizontalAlignment = xlLeft
		'表頭另外設定(header一般都是置中)
		Range(columnEng & "1").HorizontalAlignment = xlLeft
	
	End If
Next ndx
Application.ScreenUpdating = True

Column index轉換成英文:

Option Explicit

Sub ColumnIndexToEngChr()
    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)
    
    Dim FoundSortColumn1 As Range
    Set FoundSortColumn1 = FindColumn(wsSource, "ProductNo")
    MsgBox "Col_Letter(找到ProductNo的Range)的欄位英文字為:" & Col_Letter(FoundSortColumn1.Column)
    
    Dim myNum As Long
    myNum = 50
    MsgBox "Col_Letter(直接輸入數字50)的欄位英文字為:" & Col_Letter(myNum)
End Sub


'轉換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

'尋找某個欄位
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/1FjIxhYuGfn4d_jRF9Gbi4nZoPVB05uA0?usp=sharing

參考資料：
Open and Close Excel Workbook using VBA
https://analysistabs.com/excel-vba/open-close-existing-workbook/
如何凍結指定之視窗格-麻辣家族討論版
http://forum.twbts.com/thread-6285-1-1.html
Function to convert column number to letter?
https://stackoverflow.com/questions/12796973/function-to-convert-column-number-to-letter
VBA code to ungroup and regroup columns
https://www.mrexcel.com/forum/excel-questions/297921-vba-code-ungroup-regroup-columns.html

巨集VBA

回首頁

kevinya

低調

[巨集VBA]初心者學習心得03:設定欄位群組,將Column index轉換成英文letter,凍結視窗,input輸入資料,開啟檔案,取得最後一個column,所有欄位客製化置中置左置右

標籤雲