kevinya

使用正規運算式,取得資料夾內所有檔案,關閉檔案且不存檔不跳出提示:

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