優化您的VBA巨集：自動替換「部室主管:」為「核准:」的全面指南

提升工作效率，確保資料一致性與準確性的最佳實踐

三大重點摘要

最佳時機選擇：後置替換法更為穩健，避免資料覆蓋風險。
程式碼優化：新增模組化功能，提高維護性與可讀性。
效能提升：限定搜尋範圍，減少不必要的資源消耗。

一、問題背景與需求分析

您目前擁有一個VBA巨集，名為貼上執行單和CDSuploadfile內容()，其主要功能是將資料從來源活頁簿複製並貼上到目標工作表「執行單-asia」與「執行單-non-asia」。在此過程中，您希望將貼上的資料中的「部室主管:」一詞自動替換為「核准:」，以符合最新的表單格式或管理需求。

此外，您對於在資料貼上之前進行修改還是貼上之後進行修改的最佳時機存在疑問，希望能夠找到最適合的方法，以確保資料處理的效率與準確性。

二、方案比較：貼上前修改 vs. 貼上後修改

1. 貼上前修改

在將資料貼上目標工作表之前，先對來源資料進行「部室主管:」到「核准:」的替換。

優點

可避免在目標工作表中覆蓋現有的內容，有利於保留原始資料。
修改步驟融入貼上流程前端，使流程線性化。

缺點

需要確保來源資料的複製範圍準確，否則可能造成不必要的修改。
若來源資料頻繁更新，需反覆進行替換操作，增加程式碼複雜度。

2. 貼上後修改

先將資料貼上目標工作表，然後再對貼上的內容進行「部室主管:」到「核准:」的替換。

優點

操作更直觀，先完成資料貼上再進行內容修改，流程更清晰。
減少來源資料的潛在風險，確保原始資料不被改動。
更易於維護與擴展，修改與貼上步驟分離，提高程式碼的模組化程度。

缺點

需要額外的搜尋與替換步驟，可能稍微增加執行時間。
若目標工作表範圍過大，可能影響替換效率。

三、推薦方案：貼上後修改的實施策略

綜合比較後，貼上後修改的方式在維護性與風險控制方面更具優勢。以下將詳細介紹如何在您的VBA巨集中實現貼上後的自動替換功能。

1. 巨集結構調整

將替換操作模組化，並在資料貼上後呼叫替換函數，以提高程式碼的可讀性與維護性。

2. 新增替換模組

新增一個名稱為替換文字的子程序，用於在指定工作表中搜尋並替換目標文字。

3. 調整主要巨集邏輯

在資料貼上後，立即呼叫替換文字模組，確保替換操作僅作用於已貼上的內容。

4. 完整修改後的VBA巨集範例


Sub 貼上執行單和CDSuploadfile內容()
    Dim sourceWorkbook1 As Workbook
    Dim sourceWorkbook2 As Workbook
    Dim currentWorkbook As Workbook
    Dim sourceSheet1 As Worksheet
    Dim sourceSheet2 As Worksheet
    Dim targetSheet1 As Worksheet
    Dim targetSheet2 As Worksheet
    Dim datePattern As String
    Dim regExp As Object
    Dim ws As Worksheet
    Dim cell As Range
    Dim lastRow As Long
    Dim dataArray() As Variant
    Dim rowCount As Long
    Dim newWorkbook As Workbook
    Dim newWorksheet As Worksheet
    Dim newFilePath As String

    ' 設定目前活頁簿
    Set currentWorkbook = ThisWorkbook

    ' 設定正則表達式來匹配YYYYMMDD日期格式
    Set regExp = CreateObject("VBScript.RegExp")
    regExp.Pattern = "\d{8}"
    regExp.Global = False
    If regExp.Test(currentWorkbook.Name) Then
        datePattern = regExp.Execute(currentWorkbook.Name)(0)
    Else
        MsgBox "無法從檔名中提取出YYYYMMDD格式的日期！"
        Exit Sub
    End If

    ' 設定來源活頁簿路徑
    Dim sourcePath1 As String
    Dim sourcePath2 As String
    sourcePath1 = "C:\Users\VILEE00\Downloads\InternalInstruction_" & datePattern & ".xls"
    sourcePath2 = "C:\Users\VILEE00\Downloads\InternalInstruction_" & datePattern & "N.xls"

    ' 開啟來源活頁簿
    On Error Resume Next
    Set sourceWorkbook1 = Workbooks.Open(sourcePath1)
    If Err.Number <> 0 Then
        sourcePath1 = Replace(sourcePath1, ".xls", "n.xls")
        Set sourceWorkbook1 = Workbooks.Open(sourcePath1)
        If Err.Number <> 0 Then
            MsgBox "無法開啟 " & sourcePath1
            Exit Sub
        End If
    End If
    On Error GoTo 0

    Set sourceWorkbook2 = Workbooks.Open(sourcePath2)
    If Err.Number <> 0 Then
        sourcePath2 = Replace(sourcePath2, ".xls", "n.xls")
        Set sourceWorkbook2 = Workbooks.Open(sourcePath2)
        If Err.Number <> 0 Then
            MsgBox "無法開啟 " & sourcePath2
            Exit Sub
        End If
    End If

    ' 設定來源和目標工作表
    Set sourceSheet1 = sourceWorkbook1.Sheets("Sheet1")
    Set sourceSheet2 = sourceWorkbook2.Sheets("Sheet1")
    Set targetSheet1 = currentWorkbook.Sheets("執行單-asia")
    Set targetSheet2 = currentWorkbook.Sheets("執行單-non-asia")

    ' 檢查目標工作表是否隱藏，若隱藏則跳過複製操作
    If targetSheet1.Visible = xlSheetVisible Then
        sourceSheet1.Cells.Copy
        targetSheet1.Cells.PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        ' 替換貼上後的內容
        替換文字 targetSheet1, "部室主管:", "核准:"
    End If

    If targetSheet2.Visible = xlSheetVisible Then
        sourceSheet2.Cells.Copy
        targetSheet2.Cells.PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        ' 替換貼上後的內容
        替換文字 targetSheet2, "部室主管:", "核准:"
    End If

    ' 關閉來源活頁簿且不儲存變更
    sourceWorkbook1.Close SaveChanges:=False
    sourceWorkbook2.Close SaveChanges:=False

    ' 設定目標工作表
    Set ws = currentWorkbook.Sheets("CDS upload file")

    ' 找到目標工作表的最後一列
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    ' 初始化數據數組
    rowCount = 0
    ReDim dataArray(1 To lastRow - 1, 1 To 100) '假設資料列數不超過100列

    ' 遍歷D欄的每個單元格
    For Each cell In ws.Range("D2:D" & lastRow)
        If cell.Value <> "" Then
            rowCount = rowCount + 1
            dataArray(rowCount, 1) = cell.Value
            For colIndex = 1 To 100 ' 假設資料列數不超過100列
                dataArray(rowCount, colIndex) = ws.Cells(cell.Row, colIndex).Value
            Next colIndex
        End If
    Next cell

    ' 設定新活頁簿的路徑和檔名
    newFilePath = "G:\1_SA daily 作業\2_ETF_交割\ETF CDS upload file-" & datePattern & ".xlsx"

    ' 建立或開啟新活頁簿
    On Error Resume Next
    Set newWorkbook = Workbooks.Open(newFilePath)
    If Err.Number <> 0 Then
        Set newWorkbook = Workbooks.Add
        newWorkbook.SaveAs fileName:=newFilePath, FileFormat:=xlOpenXMLWorkbook
    End If
    On Error GoTo 0

    ' 設定新活頁簿中的目標工作表
    On Error Resume Next
    Set newWorksheet = newWorkbook.Sheets("TEMPLATE")
    If newWorksheet Is Nothing Then
        Set newWorksheet = newWorkbook.Sheets(1)
        newWorksheet.Name = "TEMPLATE"
    End If
    On Error GoTo 0

    ' 將數據貼上至新工作表
    If rowCount > 0 Then
        newWorksheet.Range("A2").Resize(rowCount, UBound(dataArray, 2)).Value = dataArray
    End If

    ' 儲存並關閉新活頁簿
    newWorkbook.Save
    newWorkbook.Close SaveChanges:=True

    MsgBox "資料處理完成並已匯出至 " & newFilePath
End Sub

Sub 替換文字(sheet As Worksheet, findText As String, replaceText As String)
    Dim searchRange As Range
    Dim foundCell As Range

    ' 定義搜尋範圍，這裡假設是全部使用的範圍
    Set searchRange = sheet.UsedRange

    ' 搜尋並替換內容
    Do
        Set foundCell = searchRange.Find(What:=findText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
        If Not foundCell Is Nothing Then
            foundCell.Value = Replace(foundCell.Value, findText, replaceText)
            ' 調整搜尋範圍，避免無限迴圈
            Set searchRange = sheet.Range(foundCell.Address).Resize(1, 1)
        End If
    Loop While Not foundCell Is Nothing
End Sub