存储超过它旨在导致联盟声明的问题的集合
出于某种原因，每个包含数据的列都被存储到columnsToCopy和unionVariable中。 在Locals的顶层，我可以看到它识别我真正想要的列，但是当我深入到单元格 – > WorkSheet – > UsedRange – > Value2时，它将显示我的工作簿中的所有列都被存储。 这是我分配columnsToCopy的一段代码，一路分配unionVariable，然后复制它：
checkOne = iq_Array(0) hasIQs = Left(checkOne, 3) = "iq_" Dim columnsToCopy As Collection Set columnsToCopy = New Collection If hasIQs Then ' paste inital column into temporary worksheet columnsToCopy.Add ShRef.Columns(1) End If ' loop for each iq_ in the array For arrayLoop = LBound(iq_Array) To UBound(iq_Array) ' Take copy of potential ref and adjust to standard if required checkStr = iq_Array(arrayLoop) If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr ' Look for existence of corresponding column in local copy array pCol = 0 For iCol = 2 To colNumb If checkStr = IQRef(iCol) Then pCol = iCol Exit For End If Next iCol If pCol > 0 Then ' Paste the corresponding column into the forming table columnsToCopy.Add ShRef.Columns(pCol) End If Next arrayLoop If columnsToCopy.Count > 1 Then 'data was added ' Copy table Dim unionVariable As Range Set unionVariable = columnsToCopy(1) For k = 2 To columnsToCopy.Count Set unionVariable = xlApp.Union(unionVariable, columnsToCopy(k)) Next k unionVariable.Copy ' all the data added to ShWork 我正在研究这个的原因，是因为当我Union(unionVariable, columnToCopy(k))我没有得到的东西，将相当于范围（“A：A”，“D：D”，“Z： Z“），而是我得到范围（”A：Z“）。
任何帮助表示赞赏
我的完整代码：
Option Explicit Private Sub averageScoreRelay() ' 1. Run from PPT and open an Excel file ' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72". ' 3. find those words and numbers in the opened Excel file after splitting and re-formating string. ' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table. ' 4. Copy table from xl Paste Table into ppt ' 5. Do this for every slide 'Timer start Dim StartTime As Double Dim SecondsElapsed As Double StartTime = Timer 'Create variables Dim xlApp As Excel.Application Dim xlWB As Excel.Workbook Dim ShRef As Excel.Worksheet Dim pptPres As Object Dim colNumb As Long Dim rowNumb As Long ' Create new excel instance and open relevant workbook Set xlApp = New Excel.Application 'xlApp.Visible = True 'Make Excel visible Set xlWB = xlApp.Workbooks.Open("C:\Users\Andre Kunz\Desktop\Gate\Macros\averageScores\pptxlpratice\dummy2.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook If xlWB Is Nothing Then ' may not need this if statement. check later. MsgBox ("Error retrieving Average Score Report, Check file path") Exit Sub End If xlApp.DisplayAlerts = False 'Find # of iq's in workbook Set ShRef = xlWB.Worksheets("Sheet1") colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row Dim IQRef() As String Dim iCol As Long Dim IQRngRef() As Range ReDim IQRef(colNumb) ReDim IQRngRef(colNumb) ' capture IQ refs locally For iCol = 2 To colNumb Set IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol)) IQRef(iCol) = ShRef.Cells(1, iCol).Value Next iCol 'Make pptPres the ppt active Set pptPres = PowerPoint.ActivePresentation 'Create variables for the slide loop Dim pptSlide As Slide Dim Shpe As Shape Dim pptText As String Dim iq_Array As Variant Dim arrayLoop As Long Dim myShape As Object Dim i As Long Dim lRows As Long Dim lCols As Long Dim k As Long 'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable For Each pptSlide In pptPres.Slides i = 0 pptSlide.Select 'searches through shapes in the slide For Each Shpe In pptSlide.Shapes If Not Shpe.HasTextFrame Then GoTo nextShpe 'boom, one less nested If statement If Not Shpe.TextFrame.HasText Then GoTo nextShpe ' boom, another nested If statement bites the dust 'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters pptText = Shpe.TextFrame.TextRange pptText = LCase(Replace(pptText, " ", vbNullString)) pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString) 'Identify if within text there is "iq_" If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe 'set iq_Array as an array of the split iq's iq_Array = Split(pptText, ",") Dim hasIQs As Boolean Dim checkStr As String Dim pCol As Long Dim checkOne checkOne = iq_Array(0) hasIQs = Left(checkOne, 3) = "iq_" Dim columnsToCopy As Collection Set columnsToCopy = New Collection If hasIQs Then ' paste inital column into temporary worksheet columnsToCopy.Add ShRef.Columns(1) End If ' loop for each iq_ in the array For arrayLoop = LBound(iq_Array) To UBound(iq_Array) ' Take copy of potential ref and adjust to standard if required checkStr = iq_Array(arrayLoop) If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr ' Look for existence of corresponding column in local copy array pCol = 0 For iCol = 2 To colNumb If checkStr = IQRef(iCol) Then pCol = iCol Exit For End If Next iCol If pCol > 0 Then ' Paste the corresponding column into the forming table columnsToCopy.Add ShRef.Columns(pCol) End If Next arrayLoop If columnsToCopy.Count > 1 Then 'data was added ' Copy table Dim unionVariable As Range Set unionVariable = columnsToCopy(1) For k = 2 To columnsToCopy.Count Debug.Print k & " : " & unionVariable.Address & " + " & columnsToCopy(k).Address Set unionVariable = xlApp.Union(unionVariable, columnsToCopy(k)) Debug.Print " --> " & unionVariable.Address Next k unionVariable.Copy ' all the data added to ShWork tryAgain: ActiveWindow.ViewType = ppViewNormal ActiveWindow.Panes(2).Activate Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse) On Error GoTo tryAgain 'Set position: myShape.Left = -200 myShape.Top = 150 + i i = i + 150 End If nextShpe: Next Shpe nextSlide: Next pptSlide xlWB.Close xlApp.Quit xlApp.DisplayAlerts = True 'End Timer SecondsElapsed = Round(Timer - StartTime, 2) MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation End Sub
debugging器的输出：
2 : $A:$A + $B:$B --> $A:$B 3 : $A:$B + $AF:$AF --> $A:$B,$AF:$AF 2 : $A:$A + $C:$C --> $A:$A,$C:$C 2 : $A:$A + $D:$D --> $A:$A,$D:$D 3 : $A:$A,$D:$D + $L:$L --> $A:$A,$D:$D,$L:$L
这是另一个选项没有创build临时工作簿/工作表的额外开销。
注意：它可能不完美 – 在我的testing中，它不保留单元格背景颜色，但它确实保留文本/字体格式，这看起来与PasteSpecial(ppPasteHtml)方法一致。
另请注意：这里假定您可以使用PowerPoint中的表来存储粘贴的数据，并且联合范围中的所有列都具有相同的行数。 如果您只是将数据转储到文本框或任何types的形状，这是行不通的。
但想法是，一旦我们有了“联合”，我们就可以迭代Areas和每个区域中的Columns ，对每个单独的列执行Copy和Paste操作。
这里是我在Excel中的数据，我将创build一个高亮显示的单元格的联合：
这里是PowerPoint中的输出，我从表格中删除了边框，注意保存的文本格式以及单元格alignment方式：
Option Explicit Sub foo() Dim ppt As PowerPoint.Application Dim pres As PowerPoint.Presentation Dim sld As PowerPoint.Slide Dim shp As PowerPoint.Shape Dim tbl As PowerPoint.Shape Dim unionRange As Range Dim ar As Range, c As Long, i As Long Set unionRange = Union([A1:B2], [D1:D2], [F1:F2]) Set ppt = CreateObject("PowerPoint.Application") ppt.Visible = True Set pres = ppt.ActivePresentation Set sld = pres.Slides(1) ' Create initial table with only 1 column With unionRange Set tbl = sld.Shapes.AddTable(.Rows.Count, 1) End With For Each ar In unionRange.Areas() For c = 1 To ar.Columns.Count i = i + 1 With tbl.Table ' Add columns as you iterate the columns in your unionRange If .Columns.Count < i Then .Columns.Add .Columns(i).Cells.Borders(ppBorderBottom).Transparency = 1 .Columns(i).Cells.Borders(ppBorderTop).Transparency = 1 .Columns(i).Select ar.Columns(c).Copy '// Copy the column from Excel ppt.CommandBars.ExecuteMso ("Paste") '// Paste the values to PowerPoint End With Next Next End Sub
也许更有效地处理这样的Areas ：
For Each ar In unionRange.Areas() c = ar.Columns.Count Dim tCol tCol = .Columns.Count With tbl.Table ' Add columns as you iterate the columns in your unionRange While .Columns.Count < (tCol + c) .Columns.Add Wend .Columns(tCol).Cells.Borders(ppBorderBottom).Transparency = 1 .Columns(tCol).Cells.Borders(ppBorderTop).Transparency = 1 .Columns(tCol).Select ar.Copy '// Copy the columns in THIS Area object from Excel ppt.CommandBars.ExecuteMso ("Paste") '// Paste the values to PowerPoint End With Next
但是我仍然认为大数据集的性能会比其他答案更糟糕。
这个问题似乎是由于将非连续范围粘贴到PowerPoint中造成的。
我不知道有足够的PowerPoint VBA知道是否有其他可以使用的粘贴方法，但是解决办法是创build一个新的Excel工作表，其中只包含要复制的信息，然后将该工作表复制到幻灯片：
'... Next k unionVariable.Copy ' all the data added to ShWork 'Create a temporary sheet (the workbook is being closed without saving 'so the temporary worksheet will be "lost" after we finish) xlWB.Worksheets.Add Before:=xlWB.Worksheets(1) 'Paste the data into the temporary sheet xlWB.Worksheets(1).Range("A1").PasteSpecial xlPasteValues 'Copy the temporary sheet xlWB.Worksheets(1).UsedRange.Copy tryAgain: ActiveWindow.ViewType = ppViewNormal '...