Collection storing more than it's intended to causing problems for a Union statement - vba

Question

For some reason every column with data is being stored into columnsToCopy and unionVariable. At the top levels in Locals, I can see that it recognizes the column I actually want, but when I go deeper into say Cells -> WorkSheet -> UsedRange -> Value2 it will now show that all columns in my workbook are stored. This is the piece of code that I have assigning columnsToCopy, all the way to assigning unionVariable and then Copying it:
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
The reason I'm looking into this, is because when I Union(unionVariable, columnToCopy(k)) I'm not getting something that would be equivalent to Range("A:A","D:D","Z:Z") , instead I'm getting Range("A:Z").
Any help is appreciated
My full code:
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
Output from Debugger:
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

Answer 1

Here is another option doesn't have the additional overhead of creating a temporary workbook/worksheet.
Note: It may not be perfect -- in my testing it does not preserve cell background color but it does preserve text/font formats, and this appears consistent with the PasteSpecial(ppPasteHtml) method.
Note also: this assumes you can use a Table in PowerPoint to store the pasted data, and that all columns in your union range have the same number of rows. If you're just dumping the data in to a textbox or whatever sort of shape, this won't work.
But the idea is that once we have our "union", we can iterate over the Areas, and the Columns in each area, performing the Copy and Paste operation against each individual column.
Here is my data in Excel, I will create a union of the highlighted cells:
Here is the output in PowerPoint where I removed the borders from the table, note the text formatting preserved as well as cell 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
Maybe more efficient to handle the Areas like so:
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
But I still think performance on large data set will suffer vs the other answer.

Answer 2

The issue seems to be caused by the pasting of the non-contiguous range into PowerPoint.
I don't know enough PowerPoint VBA to know whether it has some other paste method you could use, but a work-around would be to create a new Excel worksheet containing just the info you want to copy, and then to copy that worksheet to PowerPoint:
'...
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
'...