我需要有人来拯救我。我不是开发人员;我是QA。但是,我的任务是创建一个脚本,该脚本将从一个 xlsx 中获取大量数据,并根据销售人员、客户和分支机构位置创建新的 xlsx 文档。我有代码工作,但如果运行它的计算机没有内存不足,它需要几天才能运行。我将在下面发布我的代码。有什么办法可以优化它以运行得更快吗?我们星期五早上需要它。再说一遍,我是QA。如果你说做这个或做那个,我不知道你在说什么。我真的需要“用这个替换这个”。到目前为止,你们的帮助非常棒,我非常感谢你们。我不知道你为什么要做你所做的,但谢谢你这样做。
Option Explicit
' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
Dim Sheet As Worksheet
Dim Key As String
Dim Result As Worksheet: Set Result = Nothing
Key = UCase(Name)
' loop over all the worksheets
For Each Sheet In Book.Worksheets
' break out of the loop if the sheet is found
If UCase(Sheet.Name) = Key Then
Set Result = Sheet
Exit For
End If
Next Sheet
' if the sheet isn't found..
If Result Is Nothing Then
If Ignore = False Then
If Not GetSheet("Sheet1", Book, True) Is Nothing Then
' rename sheet1
Set Result = Book.Worksheets("Sheet1")
Result.Name = Name
End If
Else
' create a new sheet
Set Result = Book.Worksheets.Add
Result.Name = Name
End If
Result.Cells(1, 1) = "Rank"
Result.Cells(1, 2) = "Customer Segment"
Result.Cells(1, 3) = "Salesrep Name"
Result.Cells(1, 4) = "Main_Customer_NK"
Result.Cells(1, 5) = "Customer"
Result.Cells(1, 6) = "FY13 Sales"
Result.Cells(1, 7) = "FY13 Inv Cost GP$"
Result.Cells(1, 8) = "FY13 Inv Cost GP%"
Result.Cells(1, 9) = "Sales Growth"
Result.Cells(1, 10) = "GP Point Change"
Result.Cells(1, 11) = "Sales % Increase"
Result.Cells(1, 12) = "Budgeted Total Sales"
Result.Cells(1, 13) = "Budget GP%"
Result.Cells(1, 14) = "Budget GP$"
Result.Cells(1, 15) = "Target Account"
Result.Cells(1, 16) = "Estimated Total Purchases"
Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
Result.Cells(1, 18) = "Notes"
Result.Cells(1, 19) = "Reference 1"
Result.Cells(1, 20) = "Reference 2"
'and the rest....
End If
Set GetSheet = Result
End Function
Sub Main()
Dim Source As Worksheet
Dim Location As Workbook
Dim Sales As Worksheet
Dim LocationKey As String
Dim SalesKey As String
Dim Index As Variant
Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
Dim Row As Long
Dim InsertPos As Long
Set Source = ThisWorkbook.ActiveSheet
Row = 2 ' Skip header row
Do
' break out of the loop - assumes that the first empty row signifies the end
If Source.Cells(Row, 1).Value2 = "" Then
Exit Do
End If
LocationKey = Source.Cells(Row, 3).Value2
' look at the location, and find the workbook, creating it if required
If Map.Exists(LocationKey) Then
Set Location = Map(LocationKey)
Else
Set Location = Application.Workbooks.Add(xlWBATWorksheet)
Map.Add LocationKey, Location
End If
SalesKey = Source.Cells(Row, 5).Value2
' get the sheet for the salesperson
Set Sales = GetSheet(SalesKey, Location)
' Get the location to enter the data
InsertPos = Sales.Range("A1").End(xlDown).Row + 1
'check to see if it's a new sheet, and adjust
If InsertPos = 1048577 Then
'Stop
InsertPos = 2
'change to 65537 is using excel 2003 or before
Macro1
End If
' populate said row with the data from the source
Sales.Cells(InsertPos, 1).Value2 = Source.Cells(Row, 1)
Sales.Cells(InsertPos, 2).Value2 = Source.Cells(Row, 2)
Sales.Cells(InsertPos, 3).Value2 = Source.Cells(Row, 5)
Sales.Cells(InsertPos, 4).Value2 = Source.Cells(Row, 6)
Sales.Cells(InsertPos, 5).Value2 = Source.Cells(Row, 7)
Sales.Cells(InsertPos, 6).Value2 = Source.Cells(Row, 8)
Sales.Cells(InsertPos, 7).Value2 = Source.Cells(Row, 9)
Sales.Cells(InsertPos, 8).Value2 = Source.Cells(Row, 10)
Sales.Cells(InsertPos, 9).Value2 = Source.Cells(Row, 11)
Sales.Cells(InsertPos, 10).Value2 = Source.Cells(Row, 12)
Sales.Cells(InsertPos, 11).Value2 = Source.Cells(Row, 13)
Sales.Cells(InsertPos, 12).Value2 = Source.Cells(Row, 14)
Sales.Cells(InsertPos, 13).Value2 = Source.Cells(Row, 15)
Sales.Cells(InsertPos, 14).Value2 = Source.Cells(Row, 16)
Sales.Cells(InsertPos, 19).Value2 = Source.Cells(Row, 17)
Sales.Cells(InsertPos, 20).Value2 = Source.Cells(Row, 18)
Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"
'increment the loop
'Range("H" & InsertPos).Activate
'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))
'Range("I" & InsertPos).Activate
'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)
'Range("J" & InsertPos).Activate
'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))
Row = Row + 1
Macro2 'runs on each cell
Loop
' loop over the resulting workbooks and save them - using the location name as file name
For Each Index In Map.Keys
Set Location = Map(Index)
Location.SaveAs Filename:=Index
Next Index
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
Cells.Select
Cells.EntireColumn.AutoFit
Columns("F:G").Select
Selection.NumberFormat = "$#,##0.00"
ActiveWindow.SmallScroll ToRight:=3
Columns("H:J").Select
Selection.NumberFormat = "0.00%"
Selection.NumberFormat = "0.0%"
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
Range("K:K,M:M").Select
Range("M1").Activate
Selection.NumberFormat = "0.0%"
Range("N:N,L:L").Select
Range("L1").Activate
Selection.NumberFormat = "$#,##0.00"
ActiveWindow.SmallScroll ToRight:=5
Columns("S:T").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=-4
Range("K:K,M:M").Select
Range("M1").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Cells.Select
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Cells.Select
'Range("L9").Activate
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Cells.Select
'Cells.EntireColumn.AutoFit
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub
Sub Macro2()
'
' Macro2 Macro
'
'
Cells.EntireColumn.AutoFit
Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub