使用正規運算式,取得資料夾內所有檔案,關閉檔案且不存檔不跳出提示,get file name without extension,設定文字顏色,設定文字置中靠左靠右,取消合併儲存格並補上空白儲存格
使用正規運算式,取得資料夾內所有檔案,關閉檔案且不存檔不跳出提示:
Sub 取得資料夾內所有檔案()
'開啟PO檔案
Dim wkbTot As Workbook
'要開啟的路徑
Dim strTotFilePath As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "請選擇 資料夾"
If .Show = -1 Then ' if OK is pressed
strTotFilePath = .SelectedItems(1)
Else
MsgBox "選取 資料夾 失敗!.", vbExclamation, "Sorry!"
Exit Sub
End If
End With
Dim wsTot As Worksheet
Set wsTot = wkbTot.Sheets(1)
'取消篩選
If wsTot.FilterMode Then wsTot.ShowAllData
If wsTot.AutoFilterMode Then wsTot.AutoFilterMode = False
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
wkbTot.Activate
strTotFilePath = ActiveWorkbook.Path
Application.ScreenUpdating = False
'取得路徑內所有的檔案
Dim loopFileName As String
loopFileName = Dir(strTotFilePath & "\")
If Len(loopFileName) = 0 Then
MsgBox " 該資料夾內無任何檔案! "
Exit Sub
End If
'取得總表最後一列
Dim lastRowOfTot As Long
lastRowOfTot = GetLastRowByColumnName(wsTot, "PO#")
'取得總表C~BQ的欄位名稱(67個欄位)
Dim totHeaders() As Variant
totHeaders = Application.Index(wsTot.Range("C1", "BQ1").Value, 1, 0)
Do While Len(loopFileName) > 0
Debug.Print loopFileName
'只開啟.xlsx, .xls, 且檔案名稱符合正規運算式的檢查"RE\d+-S\d+.xls*":
Dim regEx As New RegExp
regEx.Pattern = "RE\d+-S\d+.xls*"
If (LCase(Right(loopFileName, 5)) = ".xlsx" Or LCase(Right(loopFileName, 4)) = ".xls" Or LCase(Right(loopFileName, 5)) = ".xlsb") _
And (regEx.Test(loopFileName) = True) And CheckExist(ws, loopFileName) Then
'正規運算式取match的value
Dim regExGetName As New RegExp
regExGetName.Pattern = "RE\d+-S\d+"
Dim columnBvalue As String
If regExGetName.Test(fileName) = True Then '記得一定要執行.Test(), 之後的Execute才抓的到value喔
columnBvalue = regExGetName.Execute(fileName)(0)
End If
lastRowOfTot = lastRowOfTot + 1
Dim wkbSource As Workbook
Set wkbSource = Workbooks.Open(strTotFilePath & "\" & loopFileName)
Dim wsSource As Worksheet
Set wsSource = wkbSource.Worksheets(1)
If wsSource.FilterMode Then wsSource.ShowAllData
If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
wsSource.Activate
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
wkbTot.Activate
wsTot.Activate
'save without prompting alerts
wkbSource.Activate
wsSource.Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
End If
loopFileName = Dir
Loop
'收合群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=1
Application.ScreenUpdating = True
MsgBox "成功結束!.", vbExclamation, "Success!"
End Sub
get file name without extension:
Dim fileName As String
Dim fileNameWithoutExtension As String
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
fileNameWithoutExtension = fso.GetBaseName(fileName)
設定文字顏色,設定文字置中靠左靠右:
'開啟PO檔案
Dim wkbTot As Workbook
Dim strTotFileToOpen As String
Dim strTotFilePath As String
strTotFileToOpen = ""
'透過dialog視窗取得檔案名稱
strTotFileToOpen = Application.GetOpenFilename _
(Title:="請選擇 檔案", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strTotFileToOpen = "False" Then
MsgBox "選取 檔案 失敗!.", vbExclamation, "Sorry!"
Exit Sub
Else
Set wkbTot = Workbooks.Open(strTotFileToOpen)
End If
Dim wsTot As Worksheet
Set wsTot = wkbTot.Sheets(1)
'取消篩選
If wsTot.FilterMode Then wsTot.ShowAllData
If wsTot.AutoFilterMode Then wsTot.AutoFilterMode = False
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
wkbTot.Activate
Dim firstRowOfTot As Long
Dim finalRow As Long
firstRowOfTot = 10
finalRow = 20
'設定紅色文字
Dim FoundChangeType1 As Range
Set FoundChangeType1 = FindColumn(wsTot, "Change Type1")
wsTot.Range(Col_Letter(FoundChangeType1.Column) & firstRowOfTot & ":" _
& Col_Letter(FoundChangeType1.Column) & finalRow).Font.Color = vbRed
'設定靠左
wsTot.Range(Col_Letter(FoundChangeType1.Column) & firstRowOfTot & ":" _
& Col_Letter(FoundChangeType1.Column) & finalRow).Select
With Selection
.HorizontalAlignment = xlLeft
End With
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
取消合併儲存格並補上空白儲存格:
Dim wkbSource As Workbook
Set wkbSource = Workbooks.Open(folder & "\" & fileName)
Dim wsSource As Worksheet
Set wsSource = wkbSource.Worksheets(1)
Dim lastRowOfSourceFile As Long
lastRowOfSourceFile = 10
Dim lastColumnOfSourceFile As Long
lastColumnOfSourceFile = 12
If wsPO.FilterMode Then wsPO.ShowAllData
If wsPO.AutoFilterMode Then wsPO.AutoFilterMode = False
'展開群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=2
'unmerge cell and duplicate
wkbSource.Activate
wsSource.Activate
Dim cell As Range, joinedCells As Range
For Each cell In ActiveSheet.UsedRange
If cell.MergeCells Then
Set joinedCells = cell.MergeArea
cell.MergeCells = False
joinedCells.Value = cell.Value
End If
Next
'收合群組
ActiveSheet.Outline.ShowLevels ColumnLevels:=1
參考資料:
工作經驗
vba - Unmerging excel rows, and duplicate data - Stack Overflow