VBA粘贴时字体大小变更问题求助：仅Compiled data文件异常

Let's break down why your font size is shifting only in the "Compiled data.xlsx" file, and fix the code step by step:

Key Problems in Your Current Code #

• Wrong Workbook Target for Font Settings: Your For Each ws In Worksheets loop is nested inside With InputFile.Sheets("Report"), so it's only applying font changes to the source workbook (Weekly data.xlsx), not the target files you're pasting into. The "Formulas Pivot data.xlsx" likely already uses Calibri 9 by default, which is why it doesn't show the issue.
• Invalid Path Concatenation: You're combining Inputpath with a full file path, creating a broken path like C:\Users\Workbooks\C:\Users\Workbooks\Weekly data.xlsx.
• Inefficient Font Application: Applying font settings to every worksheet in a workbook is unnecessary—you only need to target the specific sheet where you pasted the data.

Corrected VBA Code #

Sub Sites()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim InputFile As Workbook
    Dim OutputFile As Workbook
    Dim FormulasFile As Workbook
    Dim Inputpath As String
    Dim Outputpath As String
    Dim Formulaspath As String
    Dim lRow As Long
    Dim targetSheet As Worksheet
    
    ' Set base paths (no trailing slash to avoid duplication)
    Inputpath = "C:\Users\Workbooks"
    Outputpath = "C:\Users\Workbooks"
    Formulaspath = "C:\Users\Workbooks"
    
    ' Open workbooks with valid paths
    Set InputFile = Workbooks.Open(Inputpath & "\Weekly data.xlsx")
    Set OutputFile = Workbooks.Open(Outputpath & "\Compiled data.xlsx")
    Set FormulasFile = Workbooks.Open(Formulaspath & "\Formulas Pivot data.xlsx", UpdateLinks:=False)
    
    ' Copy to Compiled data.xlsx and set font
    With InputFile.Sheets("Report")
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set targetSheet = OutputFile.Sheets("Sheet1")
        ' Paste data to the next empty row
        .Range("C3:O" & lRow).Copy targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Offset(1)
        ' Apply font settings ONLY to the pasted range (13 columns: C to O)
        With targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Resize(lRow - 2, 13)
            .Font.Name = "Calibri"
            .Font.Size = 9
        End With
    End With
    
    ' Copy to Formulas Pivot data.xlsx and set font
    With InputFile.Sheets("Report")
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set targetSheet = FormulasFile.Sheets("Site")
        ' Paste data to the next empty row in column O
        .Range("C3:O" & lRow).Copy targetSheet.Cells(targetSheet.Rows.Count, "O").End(xlUp).Offset(1)
        ' Apply font settings to the pasted range
        With targetSheet.Cells(targetSheet.Rows.Count, "O").End(xlUp).Resize(lRow - 2, 13)
            .Font.Name = "Calibri"
            .Font.Size = 9
        End With
    End With
    
    ' Close workbooks
    InputFile.Close SaveChanges:=False
    OutputFile.Close SaveChanges:=True
    FormulasFile.Close SaveChanges:=True
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Additional Tips #

• Target Specific Ranges: We focused font changes only on the pasted data instead of the entire worksheet, which speeds up the code.
• Paste Values Only (Optional): If you don't need to carry over any source formatting, use PasteSpecial xlPasteValues instead of direct copy-paste, then apply your font settings. Example:

  .Range("C3:O" & lRow).Copy
  targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  

内容的提问来源于stack exchange，提问作者ABF