vba - 集合存储超出预期会导致 Union 语句出现问题

Question

出于某种原因，每个包含数据的列都存储在 columnsToCopy 和 unionVariable 中。在 Locals 的顶层，我可以看到它识别出我真正想要的列，但是当我更深入地说 Cells -> 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))我没有得到相当于 Range("A:A","D:D","Z:Z") 的东西，而是得到 Range("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

调试器的输出:

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

这是另一个选项没有创建临时工作簿/工作表的额外开销。

注:它可能并不完美——在我的测试中，它不会保留单元格背景颜色，但会保留文本/字体格式，这似乎与 PasteSpecial(ppPasteHtml) 一致。方法。

另请注意:这假定您可以使用 PowerPoint 中的表格来存储粘贴的数据，并且联合范围中的所有列都具有相同的行数。如果您只是将数据转储到文本框或任何类型的形状中，这将不起作用。

但想法是，一旦我们有了“联合”，我们就可以遍历 Areas ，以及 Columns在每个区域执行Copy和 Paste对每个单独的列进行操作。

这是我在 Excel 中的数据，我将创建突出显示的单元格的联合:



这是 PowerPoint 中的输出，我从表格中删除了边框，请注意保留的文本格式以及单元格对齐:

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

但我仍然认为大数据集的性能会受到其他答案的影响。