我想知道是否有人可以帮助我。
在我的帮助下，我将以下脚本放在一起执行以下操作：
Sub ForecastsCharts()
Dim ChtOb As ChartObject
Dim lw As Long
Dim rng As Range
Dim RngToCover As Range
Dim sShapeName As String
Dim shtrng As Range
Dim i As Long
Dim RowIndex
Dim ad As Worksheet
Dim col As Long
Dim DataRow As Long
Dim rw As Long
Sheets("All Data").Select
Application.ScreenUpdating = False
DataRow = 8
Do Until Cells(DataRow, 2).Value = "" ' Loop through All Data rows
With Sheets(Cells(DataRow, 2).Value) ' Output will go to the applicable Portfolio sheet found in column B
Set rng = .Range("B11").CurrentRegion
'If Application.CountIf(rng, "<>") = rng.Columns.Count Then ' all data points required
If Application.CountIf(rng, "<>") > 0 Then ' at least 1 data point
With ActiveSheet.Shapes.AddChart(Left:=48, Width:=468, Top:=300, Height:=300).Chart
.PlotBy = xlRows
.ChartType = xlColumnClustered
For RowIndex = 2 To rng.Rows.Count
With .SeriesCollection.NewSeries
'This is the series name
.Name = "='" & rng.Parent.Name & "'!" & rng.Cells(RowIndex, 1).Address(, , xlR1C1)
.Values = "='" & rng.Parent.Name & "'!" & rng.Rows(RowIndex).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
.XValues = "='" & rng.Parent.Name & "'!" & rng.Rows(1).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=True, ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=True, ShowBubbleSize:=False, _
Separator:="" & Chr(13) & ""
End With
Next
End With
End If
End With
Loop
End Sub
更新代码
Sub ForecastsCharts()
Dim ChtOb As ChartObject
Dim lw As Long
Dim rng As Range
Dim RngToCover As Range
Dim sShapeName As String
Dim shtrng As Range
Dim i As Long
Dim RowIndex As Long
Dim ad As Worksheet
Dim col As Long
Dim DataRow As Long
Dim rw As Long
Dim allDataSheet As Worksheet
Set allDataSheet = Sheets("All Data")
Application.ScreenUpdating = False
DataRow = 8
Do Until allDataSheet.Cells(DataRow, 2).Value = "" ' Loop through All Data rows
With Sheets(allDataSheet.Cells(DataRow, 2).Value) ' Output will go to the applicable Portfolio sheet found in column B
Set rng = .Range("B8").CurrentRegion
'If Application.CountIf(rng, "<>") = rng.Columns.Count Then ' all data points required
If Application.CountIf(rng, "<>") > 0 Then ' at least 1 data point
With .Shapes.AddChart(Left:=48, Width:=468, Top:=300, Height:=300).Chart
.PlotBy = xlRows
.ChartType = xlColumnClustered
For RowIndex = 2 To rng.Rows.Count
With .SeriesCollection.NewSeries
'This is the series name
.Name = "='" & rng.Parent.Name & "'!" & rng.Cells(RowIndex, 1).Address(, , xlR1C1)
.Values = "='" & rng.Parent.Name & "'!" & rng.Rows(RowIndex).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
.XValues = "='" & rng.Parent.Name & "'!" & rng.Rows(1).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=True, ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=True, ShowBubbleSize:=False, _
Separator:="" & Chr(13) & ""
End With
Next
End With
End If
End With
DataRow = DataRow + 1
Loop
End Sub
***工作代码***
Sub ForecastsCharts()
Dim ChtOb As ChartObject
Dim lw As Long
Dim rng As Range
Dim RngToCover As Range
Dim sShapeName As String
Dim shtrng As Range
Dim i As Long
Dim RowIndex As Long
Dim ad As Worksheet
Dim col As Long
Dim DataRow As Long
Dim rw As Long
Dim bottomB As Integer
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ad = Sheets("Portfolio List")
ad.Select
bottomB = Range("C" & Rows.Count).End(xlUp).Row
For Each rng In ad.Range("C8:C" & bottomB)
If rng > 0 Then
Set ws = Sheets(rng.Value)
Set shtrng = ws.Range("B8").CurrentRegion
'If Application.CountIf(rng, "<>") = rng.Columns.Count Then ' all data points required
With ws
If ws.Name = "Benefits & Credits" Then
If Application.CountIf(shtrng, "<>") > 0 Then ' at least 1 data point
With .Shapes.AddChart(Left:=48, Width:=468, Top:=300, Height:=300).Chart
.PlotBy = xlRows
.ChartType = xlColumnClustered
For RowIndex = 2 To shtrng.Rows.Count
With .SeriesCollection.NewSeries
'This is the series name
.Name = "='" & shtrng.Parent.Name & "'!" & shtrng.Cells(RowIndex, 1).Address(, , xlR1C1)
.Values = "='" & shtrng.Parent.Name & "'!" & shtrng.Rows(RowIndex).Cells(1, 2).Resize(1, shtrng.Columns.Count - 1).Address(, , xlR1C1)
.XValues = "='" & shtrng.Parent.Name & "'!" & shtrng.Rows(1).Cells(1, 2).Resize(1, shtrng.Columns.Count - 1).Address(, , xlR1C1)
.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=True, ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=True, ShowBubbleSize:=False, _
Separator:="" & Chr(13) & ""
End With
Next
End With
End If
End If
End With
End If
Next rng
End Sub
我知道创建图表的代码有效，因为我已经用一张表测试了这个。我还知道脚本的以下部分标识了与工作表名称匹配的唯一值也可以，因为我在另一个脚本中使用它。
DataRow = 8
Do Until Cells(DataRow, 2).Value = "" ' Loop through All Data rows
With Sheets(Cells(DataRow, 2).Value) ' Output will go to the applicable Portfolio sheet found in column B
但是，当我运行完整脚本时，我遇到的问题是Excel崩溃创建了一个＆＃34; Excel无法使用可用资源完成此任务。选择较少的数据或关闭其他应用程序＆＃34;错误消息，我不知道为什么，因为我的电脑足够强大，可以运行它。
我在这个论坛上看了类似的帖子，但遗憾的是他们还没有对这个问题有所了解。
我只是想知道是否有人可以看到这个，让我知道我哪里出错了
答案 0 :(得分：2)
我将您的目标理解为：所有数据列表中存在的每张单张图表
您的代码正在创建（如@ vba4all建议的）太多图表。我补充说：
sheetsHandled as Collection保存表格列表
已经得到了他们的图表。sheetName用于保存代码中多次使用的工作表名称。Function StringExistsInCollection的sheetName
在sheetsHandled。所以这是固定代码：
Sub ForecastsCharts()
Dim ChtOb As ChartObject
Dim lw As Long
Dim rng As Range
Dim RngToCover As Range
Dim sShapeName As String
Dim shtrng As Range
Dim i As Long
Dim RowIndex As Long
Dim ad As Worksheet
Dim col As Long
Dim DataRow As Long
Dim rw As Long
Dim allDataSheet As Worksheet
Dim sheetsHandled As New Collection 'Collection for chart references
Dim sheetName As String ' Name of the sheet being handled (used many times)
Set allDataSheet = Sheets("All Data")
Application.ScreenUpdating = False
DataRow = 8
Do Until allDataSheet.Cells(DataRow, 2).Value = "" ' Loop through All Data rows
sheetName = allDataSheet.Cells(DataRow, 2).Value 'Name is memorised here
If Not StringExistsInCollection(sheetsHandled, sheetName) Then
sheetsHandled.Add sheetName 'Remember we handled the sheet
With Sheets(sheetName) ' Output will go to the applicable Portfolio sheet found in column B
Set rng = .Range("B8").CurrentRegion
'If Application.CountIf(rng, "<>") = rng.Columns.Count Then ' All data points required
If Application.CountIf(rng, "<>") > 0 Then ' At least one data point
With .Shapes.AddChart(Left:=48, Width:=468, Top:=300, Height:=300).Chart
.PlotBy = xlRows
.ChartType = xlColumnClustered
For RowIndex = 2 To rng.Rows.Count
With .SeriesCollection.NewSeries
'This is the series name
.Name = "='" & sheetName & "'!" & rng.Cells(RowIndex, 1).Address(, , xlR1C1)
.Values = "='" & sheetName & "'!" & rng.Rows(RowIndex).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
.XValues = "='" & sheetName & "'!" & rng.Rows(1).Cells(1, 2).Resize(1, rng.Columns.Count - 1).Address(, , xlR1C1)
.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=True, ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=True, ShowBubbleSize:=False, _
Separator:="" & Chr(13) & ""
End With
Next
End With
End If
End With
End If 'End to if not sheet is handled
DataRow = DataRow + 1
Loop
End Sub
Public Function StringExistsInCollection(ByRef aCollection As Collection, item As String) As Boolean
StringExistsInCollection = False
For i = 1 To aCollection.Count
If aCollection(i) = item Then
StringExistsInCollection = True
Exit Function
End If
Next i
End Function
答案 1 :(得分：0)
尝试这个......它使用数组3来精确地测试除了创建图表之外的一切。我有大约一千行的数字和大约6张它在几秒钟内找到了匹配。使用数组迭代比迭代单元格的内存密集程度要低得多......
Option Explicit
Sub ForecastsCharts()
Dim ChtOb As ChartObject
Dim lw As Long
Dim rng As Range
Dim RngToCover As Range
Dim sShapeName As String
Dim shtrng As Range
Dim i As Long
Dim RowIndex As Long
Dim ad As Worksheet
Dim ws As Worksheet
Dim col As Long
Dim DataRow As Long
Dim rw As Long
Dim PortListArr As Variant, p As Variant
Dim SheetNameArr As Variant, s As Variant
Dim wb As Workbook
Dim MatchSheetArr() As Variant, m As Long
Set wb = ThisWorkbook
Application.ScreenUpdating = False
Set ad = Sheets("Portfolio List")
'get array of sheet Names
ReDim SheetNameArr(0 To Sheets.Count - 1)
For i = 0 To Sheets.Count - 1
If wb.Sheets(i + 1).Name <> "Portfolio List" Then
SheetNameArr(i) = wb.Sheets(i + 1).Name
End If
Next i
'get arry of numbers
PortListArr = ad.Range("C2", Range("C" & Rows.Count).End(xlUp)).Value
m = 0
'loop through each element of numbers and compare with each sheet name if match is found populate into new array
For Each p In PortListArr
For Each s In SheetNameArr
If "Sheet" & p = s Then
ReDim Preserve MatchSheetArr(m)
MatchSheetArr(m) = s
Debug.Print MatchSheetArr(m)
m = m + 1
End If
Next s
Next p
Set SheetNameArr = Nothing
Set PortListArr = Nothing
Set p = Nothing
For Each s In MatchSheetArr 'array of only matched sheet names
Set ws = wb.Worksheets(s)
Set shtrng = ws.Range("B8").CurrentRegion
If Application.CountIf(shtrng, "<>") > 0 Then ' at least 1 data point
With ws.Shapes.AddChart(Left:=48, Width:=468, Top:=300, Height:=300).Chart
.PlotBy = xlRows
.ChartType = xlColumnClustered
For RowIndex = 2 To shtrng.Rows.Count
With .SeriesCollection.NewSeries
'This is the series name
.Name = "='" & shtrng.Parent.Name & "'!" & shtrng.Cells(RowIndex, 1).Address(, , xlR1C1)
.Values = "='" & shtrng.Parent.Name & "'!" & shtrng.Rows(RowIndex).Cells(1, 2).Resize(1, shtrng.Columns.Count - 1).Address(, , xlR1C1)
.XValues = "='" & shtrng.Parent.Name & "'!" & shtrng.Rows(1).Cells(1, 2).Resize(1, shtrng.Columns.Count - 1).Address(, , xlR1C1)
.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=True, ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
ShowPercentage:=True, ShowBubbleSize:=False, _
Separator:="" & Chr(13) & ""
End With
Next
End With
End If
Next
Set s = Nothing
Set MatchSheetArr = Nothing
End Sub
答案 2 :(得分：0)
您可以从Excel之外的日志文件中受益，以帮助您跟踪发生的情况。这是一个简化的函数，我用它来跟踪正在发生的事情。它将您提供给函数的文本写入文本文件，因此即使excel崩溃，您仍然拥有日志。 您可以将它与此post
中的GetProcessMemory函数结合使用Option Explicit
Sub Heartbeat(LogText As String)
'-----------------------------------------------------------------------------
'Purpose Enable logging where the program is
'Expects LogText The freetext log that describes what is being logged.
'-----------------------------------------------------------------------------
'Usage Heartbeat "this text will end up in the text-file"
' Heartbeat GetProcessMemory("EXCEL.EXE") 'requires the GetProcessMemory function
' https://stackoverflow.com/questions/17202892/to-find-the-memory-usage-of-a-particular-process
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'Changelog
'HANY 20140416
' Created
'-----------------------------------------------------------------------------
Dim fname As String
Dim myLogText As String
Dim myfilenumber As Integer
'If there are any ' or " in the log-text, take them away.
myLogText = Replace(LogText, "'", "*")
myLogText = Replace(myLogText, """", "*")
'----------------------------------------------------
'Log in the text-file
'----------------------------------------------------
fname = "Mylogfile.log.txt"
myfilenumber = FreeFile
Open fname For Append As #myfilenumber
Print #myfilenumber, FormatLogTime(Now()) & "--" & LogText
Close #myfilenumber
End Sub
Function FormatLogTime(iDate As Date) As String
FormatLogTime = Right("0000" & Year(iDate), 4) _
& Right("00" & Month(iDate), 2) _
& Right("00" & Day(iDate), 2) _
& " " _
& Right("00" & Hour(iDate), 2) _
& "." _
& Right("00" & Minute(iDate), 2) _
& "." _
& Right("00" & Second(iDate), 2)
End Function
答案 3 :(得分：-1)
尝试在Loop上方添加此内容：
DataRow = DataRow + 1
你可能没有超越范围。 （在使用断点运行代码时，这很容易检查。）
在添加上面建议的行后，您可能会更改：
Do Until Cells(DataRow, 2).Value = ""
为：
Do Until Cells(DataRow, 2).Value = "" Or DataRow > 12
这个想法是尽早停止资源使用。如果代码在没有引发错误的情况下工作，您当然不会得到所需的结果，但您可以更好地找到问题。