我有一个工作簿，我从一个主电子表格创建并复制值。我遇到的唯一问题是我无法限制滚动区域，因为滚动区域在关闭时不会保存。有没有办法在每个新工作簿中创建一个宏，在创建新工作簿时打开滚动区域？这就是我现在所拥有的：
Sub ProgramExport()
'Dim arr
'arr3 = Array("Accessible Pedestrian Signals", "Advanced Traffic Signal Control ", "Bathurst Street Bridge Rehabilitation ", "C.I. Centennial Pk Path", _
"C.I. Etobicoke Valley PK", "C.I. Humber Trail Extension and Gaps", "C.I. Pan Am Trail Expansion - Gatineau Trail", _
"City Bridge Rehabilitation ", "City-10-Surface Transit Operational Improvement Studies - Phase 3", _
"City-11-King Street Modelling Study", "City-12-REimagining Yonge North Study", "City-15-Flemingdon Park-Thorncliffe Park Neighbourhood Cycling Connections", _
"City-22-Accessible Pedestrian Signals Expansion", "City-26-Geometric Safety Improvements - Removal of Channelized Right Turns", _
"City-27-Missing sidewalk links - 2017", "City-28-Missing sidewalk links - 2018", "City-37-Installation of Cycling Facilites on Woodbine Ave.", _
"City-38-Installation of Cycling Facilities on Lakeshore Blvd West", "City-39-Surface Transit Operational Improvement Studies - Phase 1", _
"City-40-King Street Pilot Implementation", "City-42-Yonge Tomorrow", "City-6-Eglinton Connects Streetscape Improvements and Cycle Tracks", _
"City-8-East Don Trail", "City-9-Surface Transit Operational Improvement Studies - Phase 2", "Critical Interim Road Rehabilitation ", _
"Cycling Infrastructure ", "Design of Cherry St Realignment and Bridges", "Ditch Rehabilitation and Culvert Reconstruction", _
"Don Valley Parkway Rehabilitation", "Engineering Studies", "F.G. Gardiner Interim Repairs", "Facility Improvements ", _
"Georgetown South City Infrastructure Upgrades", "Greenville and Yonge Street Improvements", _
"Growth Related Capital Works ", "Guide Rail Replacement Program", "John Street Revitalization Project", "King Liberty Cycling Pedestrian Bridge", _
"Laneways", "LARP (Lawrence-Allen Revitalization Project) Phase 1", "LED signal Module Conversion ", "Legion Road Extension & Grade Separation", _
"Local Road Rehabilitation", "Local Speed Limit Reduction", "Major Roads Rehabilitation", "Major SOGR Pooled Contingency ", _
"N.I. Mill Street Streetscape", "N.I. The Queensway from Islington to Royal York", "Neighborhood Improvements", _
"North York Service Road Extension", "Pedestrian Safety and Infrastructure Program", _
"Port Union Road ( Lawrence Ave - Kingston Rd)", "PSI Homewood Depressed Curb", "PXO Visibility Enhancement", _
"Regent Park Revitalization ", "Retaining Walls Rehabilitation ", "Road Safety Plan (LGTSI) ", "Rouge National Park ", _
"Salt Management Program", "Sidewalks", "Signs and Markings Asset Management", "Six Points Interchange Redevelopment", _
"SM Bay Cloverdale", "SM McGill-Granby Village", "SM The Upper Avenue", "Steeles Widenings ( Tapscott Road - Beare Road) ", _
"System Enhancements for Road Repair & Permits", "Tactile Domes Installation", "Third Party Signals ", "Traffic - Control RESCU", _
"Traffic Calming", "Traffic Congestion Management ", _
"Traffic Signals Major Modifications", "Transportation Safety & Local Improvement Program ", "Work for TTC & Others", _
"Yonge Street Revitalization EA Study (Reimagining Yonge)")
Dim Program As Range
Dim rng As Range
Dim wbThis As Workbook
Dim newBook As Workbook
Dim value As String
Dim userID As String
Dim fn As String
Dim programN As Variant
Dim Cell As Range
Dim sName As String
userID = InputBox("Please enter your user id.")
'For Each programN In arr3
programN = "Local Road Rehabilitation"
Set Program = Range("C1:C2000")
Set newBook = Workbooks.Add
'UserForm1.Show
Set wbThis = Workbooks("TS L2L3v111.xlsm")
Dim test As Worksheet: Set test = wbThis.Worksheets(4)
'value = InputBox("Please enter the program you'd like to export.")
fn = "C:\Users\" & userID & "\Desktop\" & programN & ".xlsx"
'aFN = "C:\Users\ashaikh5\Desktop\Copy of TS L2L3v11.xlsm"
newBook.SaveAs (fn)
'FileFormat:=52
For i = 1 To 2000
If test.Cells(i, 3) = programN Then
If rng Is Nothing Then
Set rng = test.Range(test.Cells(i, 1), test.Cells(i, 100))
Else
Set rng = Union(rng, test.Range(test.Cells(i, 1), test.Cells(i, 100)))
End If
Else
'something
End If
Next i
'For Each Cell In Program
'If Cell = programN Then
'If rng Is Nothing Then
'Set rng = Cell.Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 78))
'Else
'r = ActiveCell.Row
'Set rng = Union(rng, Cell.Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 78)))
'End If
'Else
'cell.Font.ColorIndex = 3
'End If
'Next
Dim ws As Worksheet: Set ws = newBook.Worksheets(1)
erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If Not rng Is Nothing Then
rng.Copy
Else
MsgBox "rng was not set in the for loop"
End If
ws.Cells(erow, 1).PasteSpecial
'ws.Cells(erow, 1).PasteSpecial xlPasteFormats
'ws.Cells(erow, 1).PasteSpecial xlPasteValues
ws.Columns("A:L").ColumnWidth = 14
ws.Columns("C").AutoFit
ws.Columns("N:CM").ColumnWidth = 14
'Set wbThis = Workbooks("TS L2L3v111.xlsm")
'Dim test As Worksheet: Set test = wbThis.Worksheets(4)
test.Range("A2:CV2").Copy
ws.Cells(1, 1).PasteSpecial
ws.Columns("F:K").Columns.Group
ws.Columns("F:K").EntireColumn.Hidden = True
ws.Columns("R:Z").Columns.Group
ws.Columns("R:Z").EntireColumn.Hidden = True
ws.Columns("AH:AP").Columns.Group
ws.Columns("AH:AP").EntireColumn.Hidden = True
ws.Columns("AX:BF").Columns.Group
ws.Columns("AX:BF").EntireColumn.Hidden = True
ws.Columns("BJ:BN").Columns.Group
ws.Columns("BJ:BN").EntireColumn.Hidden = True
ws.Columns("BP:CA").Columns.Group
ws.Columns("BP:CA").EntireColumn.Hidden = True
ws.Range("A1", "CM1").End(xlUp).AutoFilter 1
ActiveWindow.SplitColumn = 13
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 80
'ws.Columns("CW:FX").Clear
ws.Cells.Validation.Delete
ws.ScrollArea = "A1:CV2000"
newBook.Save
newBook.Close
'Next programN
End Sub
答案 0 :(得分：0)
虽然您自己解决了问题，但是如果有人在将来发现这一点 - 将代码添加到新创建的工作簿中的最简单的解决方案是将新工作簿基于已支持所需代码的启用宏的模板。而不是
Set wb = workbooks.new
使用
Set wb = workbooks.new("c:\somedir\mytemplate.xltm")