我开发了以下代码，用于我从头开始创建的预算模板。目的是将实际GL数据信息自动填充到工作簿中的假设选项卡中。我使用一个特定月份作为测试。我已设置假设选项卡，以便有大约26个不同的区域办事处信息部分，以确定适当的预测。
并非所有GL都是逐项列出的。我已将GL用于特定费用（其他管理员）的类别。我有大约5种主要类别的花费，其余的GL被认为是＆＃34;其他＆＃34;。由于类别的标题与GL帐户的标题不完全相同，因此我必须在工作簿的单独选项卡上创建地图网格，以便将类别名称与不同的GL链接起来。
最终目标是：
以下代码仅循环并计算Eviction GL的支出。我希望改进性能改进代码，更轻松的未来维护（灵活性）和效率。最终目标是循环使用不同类型的支出。截至目前，我的解决方案是重复变量/范围声明，用EvictionRg代替下一次花费，以及添加另一个 case 。
我担心代码会变得太长，性能可能会受到威胁。任何有关我如何计划，修改代码等的见解和指导，以帮助我这样做将不胜感激。通过实际绘制流程图和其他方法帮助我进行头脑风暴并阅读SO上的其他帖子，我已经在这三天试图找出它。我担心我的VBA知识结束了。
Sub Try()
'Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Set Wb1 = Workbooks("SubModel Forecast_Other Admin v4.xlsm")
Set Wb2 = Workbooks("Feb15 PNL.xlsx")
Dim Wk4 As Worksheet
Set Wk4 = Wb1.Sheets("ASSUMPTIONS")
Dim Wk5 As Worksheet
Set Wk5 = Wb1.Sheets("Validation")
Dim Wk7 As Worksheet
Set Wk7 = Wb1.Sheets("GL Mapping")
Dim Wk1 As Worksheet
Set Wk1 = Wb2.Sheets("det")
Dim fname As String
fname = "Feb15 PNL"
With Wb1 '----submodel
With Wk5 '---validation tab
Dim CCCol As Long
Dim fRowCC As Long
Dim lRowCC As Long
CCCol = Wk5.Cells.Find("Cost Center", lookat:=xlWhole).Column
fRowCC = Wk5.Cells.Find("Cost Center", lookat:=xlWhole).Offset(1, 0).row
lRowCC = Wk5.Cells.Find("Cost Center", lookat:=xlWhole).End(xlDown).row
'---Determine cost center code column range and it's corresponding Region Office Name(ClinkRg)
Dim CCRg As Range
Set CCRg = Wk5.Range(Wk5.Cells(fRowCC, CCCol), Wk5.Cells(lRowCC, CCCol))
Dim CLinkRg As Range
Set CLinkRg = Wk5.Range(Wk5.Cells(fRowCC, CCCol).Offset(0, -1), Wk5.Cells(lRowCC, CCCol).Offset(0, -1))
End With '----closes W5 Validation tab
'----Grid that contains GL accounts and their category type
With Wk7
Dim MapGLCol As Long
MapGLCol = Wk7.Cells.Find("GL", lookat:=xlWhole).Column
Dim MapfRow As Long
MapfRow = Wk7.Cells.Find("GL", lookat:=xlWhole).Offset(1, 0).row
Dim MaplRow As Long
MaplRow = Wk7.Cells(rows.Count, MapGLCol).End(xlUp).row
Dim MapGLRg As Range
Set MapGLRg = Wk7.Range(Wk7.Cells(MapfRow, MapGLCol), Wk7.Cells(MapfRow, MapGLCol))
Dim TypeRg As Range
Set TypeRg = Wk7.Range(Wk7.Cells(MapfRow, MapGLCol).Offset(0, -1), Wk7.Cells(MaplRow, MapGLCol).Offset(0, -1))
End With '--closes wk7 - GL Mapping
End With '--closes Wb1 - SubModel file
'---------PNL wkb
With Wb2
With Wk1
'If Left(Wk2.Name, 5) = "By PM" Then
Dim OpsCol As Long
OpsCol = Wk1.Cells.Find("Property Manager", lookat:=xlWhole).Column
'Else
' OpsCol = Wk1.Cells.Find("Submarket", lookat:=xlWhole).Column
'End If
Dim FRow As Long
Dim LRow As Long
'Dim ExpCol As Long
Dim PropCodeCol As Long
'Dim Expense As String
'Expense = InputBox("Enter Expense GL")
'to locate begining and ending row of data on PNL report
'Identifies the column where the SubMarket names are located for lookup purposes
'Defines the expense GL column to lookup based on the inputbox above
FRow = Wk1.Cells.Find("66990000", lookat:=xlPart).Offset(2, 0).row
LRow = Wk1.Cells.Find("66990000", lookat:=xlPart).End(xlDown).Offset(-1, 0).row
'ExpCol = Wk1.Cells.Find(Expense, lookat:=xlPart).Column
PropCodeCol = Wk1.Cells.Find("Property Code", lookat:=xlWhole).Column
'Defines the Range of the PM
Dim OpsRg As Range
Set OpsRg = Wk1.Range(Wk1.Cells(FRow, OpsCol), Wk1.Cells(LRow, OpsCol))
'Defines the Range of the Property Codes
Dim PropCodeRg As Range
Set PropCodeRg = Wk1.Range(Wk1.Cells(FRow, PropCodeCol), Wk1.Cells(LRow, PropCodeCol))
'Defines the exact range of the expense column being analyzed
'Dim ExpRg As Range
'Set ExpRg = Wk1.Range(Wk1.Cells(FRow, ExpCol), Wk1.Cells(LRow, ExpCol))
'Defining range for GLs under Other Admin
Dim GLRow As Long
Dim BegGLCol As Long
Dim EndGLCol As Long
GLRow = Wk1.Cells.Find("66550000", lookat:=xlPart).row
BegGLCol = Wk1.Cells.Find("66550000", lookat:=xlPart).Column
EndGLCol = Wk1.Cells.Find("66990000", lookat:=xlPart).Column
Dim GLRg As Range
Set GLRg = Wk1.Range(Wk1.Cells(GLRow, BegGLCol), Wk1.Cells(GLRow, EndGLCol))
'----Find All GL accounts in WB1 Wk5 Validation Tab range TypeRg categorized as Evictions($)
'----Then Look up each GL account in the row with all the GLs in the current workbook PNL and Wk1
'----------Set that up as TempCell
'----------Set the range for the entire column of data for each GL and consolidate as one range 'EvictionRg'
'----------Purpose of this is to set up one range for all GL accounts categorized as Eviction GL accoutns
Dim c As Range
For Each c In TypeRg
If c = "Evictions ($)" Then
Dim TempCell As Range
Set TempCell = GLRg.Find(c.Offset(0, 1).Value, lookat:=xlWhole)
'MsgBox (TempCell)
Dim EvictionRg As Range
If EvictionRg Is Nothing Then
Set EvictionRg = Wk1.Range(Wk1.Cells(FRow, TempCell.Column), Wk1.Cells(LRow, TempCell.Column))
Else
Set EvictionRg = Union(EvictionRg, Wk1.Range(Wk1.Cells(FRow, TempCell.Column), Wk1.Cells(LRow, TempCell.Column)))
End If
End If
Next c
'---Sum up all the amounts under all the GL eviction accounts and set them as "z"
Dim z As Double
z = Application.WorksheetFunction.Sum(EvictionRg)
'---Define Ranges for All Entities, Cost Centers, Entities Not Cost Centers
'Define the range on the Property PNL workbook all items booked under an entity
Dim AllEntRg As Range
Dim cell As Range
For Each cell In OpsRg
If cell = "" Then
If AllEntRg Is Nothing Then
Set AllEntRg = Wk1.Cells(cell.row, PropCodeCol)
Else
Set AllEntRg = Union(AllEntRg, Wk1.Cells(cell.row, PropCodeCol))
End If
End If
Next cell
'Define the range of the property PNL workbook that are Entity codes that are NOT Cost Center Codes
'---Entity Codes and Cost Center Codes are within the AllEntRg
'---Create a new range in the Eviction GL Range that intersects
'---------the rows of the entity only codes and the eviction GL columns
With AllEntRg
Dim EntityRg As Range
Dim cl As Range
For Each cl In AllEntRg
If CCRg.Find(cl.Value, lookat:=xlWhole) Is Nothing Then
Dim cl2 As Range
For Each cl2 In EvictionRg '------extra
If cl2.row = cl.row Then '------extra
If EntityRg Is Nothing Then
Set EntityRg = cl2
Else
Set EntityRg = Union(EntityRg, cl2)
End If
End If
Next cl2
End If
Next cl
'MsgBox (EntityRg.Address)
Dim v As Double
v = Application.WorksheetFunction.Sum(EntityRg)
End With
'With AllEntRg
'Dim CostCRg As Range
'Dim r As Range
'For Each r In AllEntRg
' If Not CCRg.Find(r.Value, lookat:=xlWhole) Is Nothing Then
' Dim cl3 As Range
' For Each cl3 In EvictionRg
' If cl3.row = r.row Then
' If CostCRg Is Nothing Then
' Set CostCRg = cl3
' Else
' Set CostCRg = Union(CostCRg, cl3)
' End If
' End If
' Next cl3
' End If
'Next r
'End With
'MsgBox (CostCRg.Address)
'Define cell ranges for regional PM offices that contain more than one cost center ocde
With AllEntRg
If Not AllEntRg.Find("cahied", lookat:=xlWhole) Is Nothing Then
Dim n As Range
Set n = AllEntRg.Find("cahied", lookat:=xlWhole)
End If
'MsgBox (n.Address)
If Not AllEntRg.Find("cahrvr", lookat:=xlWhole) Is Nothing Then
Dim n2 As Range
Set n2 = AllEntRg.Find("cahrvr", lookat:=xlWhole)
'MsgBox (n2.Address)
End If
If Not AllEntRg.Find("atlnw", lookat:=xlWhole) Is Nothing Then
Dim an1 As Range
Set an1 = AllEntRg.Find("atlnw", lookat:=xlWhole)
'MsgBox (an1.Address)
End If
If Not AllEntRg.Find("atln", lookat:=xlWhole) Is Nothing Then
Dim an2 As Range
Set an2 = AllEntRg.Find("atln", lookat:=xlWhole)
'MsgBox (an2.Address)
End If
If Not AllEntRg.Find("atlse", lookat:=xlWhole) Is Nothing Then
Dim ae1 As Range
Set ae1 = AllEntRg.Find("atlse", lookat:=xlWhole)
'MsgBox (ae1.Address)
End If
If Not AllEntRg.Find("atle", lookat:=xlWhole) Is Nothing Then
Dim ae2 As Range
Set ae2 = AllEntRg.Find("atle", lookat:=xlWhole)
'MsgBox (ae2.Address)
End If
If Not AllEntRg.Find("atlsw", lookat:=xlWhole) Is Nothing Then
Dim as1 As Range
Set as1 = AllEntRg.Find("atlsw", lookat:=xlWhole)
'MsgBox (as1.Address)
End If
If Not AllEntRg.Find("atls", lookat:=xlWhole) Is Nothing Then
Dim as2 As Range
Set as2 = AllEntRg.Find("atls", lookat:=xlWhole)
'MsgBox (as2.Address)
End If
End With
'---Create a new range in the Eviction GL Range that intersects
'---------the rows of the specific cost center codes and the eviction GL columns
If Not n Is Nothing Or Not n2 Is Nothing Then
Dim n3 As Range
For Each n3 In EvictionRg
If n3.row = n.row Or n3.row = n2.row Then
Dim InlandRg As Range
If InlandRg Is Nothing Then
Set InlandRg = n3
Else
Set InlandRg = Union(InlandRg, n3)
End If
End If
Next n3
End If
Dim n3v As Double
n3v = Application.WorksheetFunction.Sum(InlandRg)
If Not an1 Is Nothing Or Not an2 Is Nothing Then
Dim an3 As Range
For Each an3 In EvictionRg
If an3.row = an1.row Or an3.row = an2.row Then
Dim ATLNrg As Range
If ATLNrg Is Nothing Then
Set ATLNrg = an3
Else
Set ATLNrg = Union(ATLNrg, an3)
End If
End If
Next an3
End If
Dim an3v As Double
an3v = Application.WorksheetFunction.Sum(ATLNrg)
If Not ae1 Is Nothing Or Not ae2 Is Nothing Then
Dim ae3 As Range
For Each ae3 In EvictionRg
If ae3.row = ae1.row Or ae3.row = ae2.row Then
Dim ATLErg As Range
If ATLErg Is Nothing Then
Set ATLErg = ae3
Else
Set ATLErg = Union(ATLErg, ae3)
End If
End If
Next ae3
End If
Dim ae3v As Double
ae3v = Application.WorksheetFunction.Sum(ATLErg)
If Not as1 Is Nothing Or Not as2 Is Nothing Then
Dim as3 As Range
For Each as3 In EvictionRg
If as3.row = as1.row Or as3.row = as2.row Then
Dim ATLSrg As Range
If ATLSrg Is Nothing Then
Set ATLSrg = as3
Else
Set ATLSrg = Union(ATLSrg, as3)
End If
End If
Next as3
End If
Dim as3v As Double
as3v = Application.WorksheetFunction.Sum(ATLSrg)
End With '---closes Wk1 (PNL report)
End With '--closes wb2
''--------Cycle through the different PM regional office section (column) in assumptions tab
'---------Identify where Evictions ($) is located
'---------calculate total eviction GL amounts for each section (by Entity code only, by PM + cost center code)
With Wb1
With Wk4
Wk4.Outline.ShowLevels RowLevels:=2
Dim dateRow As Long
dateRow = Wk4.Cells.Find("ACT", lookat:=xlWhole).Offset(1, 0).row
Dim fRow2 As Long
Dim AssumCol As Long
Dim lRow2 As Long
fRow2 = Wk4.Cells.Find("Global Assumptions", lookat:=xlWhole).row
AssumCol = Wk4.Cells.Find("Global Assumptions", lookat:=xlWhole).Column
lRow2 = Wk4.Cells(rows.Count, AssumCol).End(xlUp).row
Dim AssumptionRg As Range
Set AssumptionRg = Wk4.Range(Wk4.Cells(fRow2, AssumCol), Wk4.Cells(lRow2, AssumCol))
Dim r2 As Range
Dim isItem As Boolean
For Each r2 In AssumptionRg
Select Case r2
Case "Evictions ($)"
isItem = True
Dim PM As Range
Set PM = r2.End(xlUp)
'---If PM Label is Entity Level, Inland Empire or is one of the Atlanta PMs then
'-----IF Entity Level, the sum up the Entity Range for the Evictions
'-----IF Inland Empire, sum up Inland Empire properties and Inland Empire Cost Center entries
'-----IF Atlanta, the sum up Atlanta PMs and their cost center entries individually
If PM = "Tie-Out To Actuals" Or PM = "Entity Level Assumptions" _
Or PM = "Inland Empire" Or PM = "Atlanta East" _
Or PM = "Atlanta North" Or PM = "Atlanta South" Then
If PM = "Tie-Out To Actuals" Then
Wk4.Cells(r2.row, 4) = z
End If
If PM = "Entity Level Assumptions" Then
Wk4.Cells(r2.row, 4) = v
End If
If PM = "Inland Empire" Then
Wk4.Cells(r2.row, 4).Formula = _
"=SUMPRODUCT(('[" & fname & ".xlsx]det'!" & OpsRg.Address & "=" & PM.Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")" _
& "+" & n3v
Wk4.Cells(r2.row, 4).Value = Wk4.Cells(r2.row, 4).Value
End If
If PM = "Atlanta East" Then
Wk4.Cells(r2.row, 4).Formula = _
"=SUMPRODUCT(('[" & fname & ".xlsx]det'!" & OpsRg.Address & "=" & PM.Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")" _
& "+" & ae3v
End If
If PM = "Atlanta North" Then
Wk4.Cells(r2.row, 4).Formula = _
"=SUMPRODUCT(('[" & fname & ".xlsx]det'!" & OpsRg.Address & "=" & PM.Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")" _
& "+" & an3v
End If
If PM = "Atlanta South" Then
Wk4.Cells(r2.row, 4).Formula = _
"=SUMPRODUCT(('[" & fname & ".xlsx]det'!" & OpsRg.Address & "=" & PM.Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")" _
& "+" & as3v
End If
Else
Dim CCCodeRow As Long
Dim CCCodeCol As Long
CCCodeRow = CLinkRg.Find(PM.Value, lookat:=xlWhole).Offset(0, 1).row
CCCodeCol = CLinkRg.Find(PM.Value, lookat:=xlWhole).Offset(0, 1).Column
If Wk5.Cells(CCCodeRow, CCCodeCol).Value = "None" Then
Wk4.Cells(r2.row, 4).Formula = _
"=SUMPRODUCT(('[" & fname & ".xlsx]det'!" & OpsRg.Address & "=" & PM.Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")"
Else
Wk4.Cells(r2.row, 4).Formula = _
"=SUMPRODUCT(('[" & fname & ".xlsx]det'!" & OpsRg.Address & "=" & PM.Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")" _
& "+SUMPRODUCT(('[" & fname & ".xlsx]det'!" & PropCodeRg.Address & "=" & "Validation!" & Wk5.Cells(CCCodeRow, CCCodeCol).Address & ")*'[" & fname & ".xlsx]det'!" & EvictionRg.Address & ")"
End If
End If
End Select
Next r2
Set r2 = Nothing
Set Wk4 = Nothing
End With '---closes assumptions tab
End With '---workbook2
'Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
答案 0 :(得分：2)
哇，这是完全阅读！虽然我同意Comintern的观点，但我确实看到了一个非常简单的解决方案来修改代码并使其更易于维护。
我没有看到整个事情中的单一功能。如果你编写的脚本很长，而不是使用它们，你需要开始......它们会改变你的生活。
让我们看一个简单的块，我看到重复几（8）次。请注意，我看到几个更大的块在整个过程中重复出现，但这个块很容易学习。
If Not AllEntRg.Find("atlsw", lookat:=xlWhole) Is Nothing Then
Dim as1 As Range
Set as1 = AllEntRg.Find("atlsw", lookat:=xlWhole)
End If
我只看到三个因素从if到if在这部分代码中变化，输入端的2是范围和字符串，如果条件满足则输出范围。所以你编写一个这样的函数，并将它放在同一工作簿中的任何模块中。
Public Function DefMultiCCPMRange(rngSearchRange as range, strSearchString as string)as range
If Not AllEndRg.Find(strSearchString, lookat:=xlWhole) Is Nothing Then
set DefMultiCCPMRange = rngSearchRange.Find(strSearchString, Lookat:=xlWhole)
End If
End Function
现在不要一遍又一遍地重写。
If Not AllEntRg.Find("atlsw", lookat:=xlWhole) Is Nothing Then
Dim as1 As Range
Set as1 = AllEntRg.Find("atlsw", lookat:=xlWhole)
End If
你一遍又一遍地写下这个。
Dim as1 as Range
set as1 = DefMultiCCPMRange(AllEndRg,"atlsw")
此外，函数中使用的变量的生命周期在函数结束时结束，因此您不会在运行的整个持续时间内存储在内存中使用的每个变量。
如果你玩它，这应该会让你走很长的路。
我还会研究数组，集合和字典项。一旦你看到他们的力量所在的位置，他们也会改变你的生活。您可以获得创意，而不是声明和设置该范围8次，您可以执行for循环，并将它们全部放在一个以CC代码命名的对象中。
Dim arrCCCodes(3) as string 'change to arrCCCodes(7) for your 8 codes
arrCCCodes(0) = "cahied"
arrCCCodes(1) = "cahrvr"
arrCCCodes(2) = "atlnw"
arrCCCodes(3) = "atln"
'etc...
'add a reference to Microsoft scripting runtime
Dim odicCCRanges as New Dictionary
For i = 0 to UBound(arrCCCodes)
odicCCRanges.Add arrCCCodes(i), DefMultiCCPMRange(AllEndRg, arrCCCodes(i))
next
这将为您提供一个包含4个范围的字典对象（在您的实际代码中为8），更不用说丢失几页代码了。您可以调用odicCCRanges("cahied").Item(1)或odicCCRanges(arrCCCodes(0)).Item(1)范围内的值。这是它增加项目生命周期的地方。如果你需要添加一个新的CC，你只需更改arrCCCodes声明以包含一个项目，然后在下面添加它，我们的其余代码将自动获取它，运行定义范围功能，并添加它到字典。
您的代码看起来并不那么糟糕，您对空值的测试，以及声明您的变量，都是好东西。这只是所有系列剧本。尝试单步执行代码，并在VBA IDE中查看本地窗口。特别是在设置之后扩展范围节点。它会让你大开眼界范围对象中的实际内容。
答案 1 :(得分：0)
你显然有很多时间投入这个，但我真的认为你已经过度复杂了。由于您的所有代码都在构建范围然后对它们求和，我认为您可以使用数组公式来完成此操作。