PPT宏问题：数据无法按行列比例正确粘贴至目标表格

现有PPT VBA宏PasteDataWithTargetFormat可将剪贴板数据粘贴至现有表格的连续单元格，并继承光标所在目标单元格的格式，但存在数据分布错误：当粘贴2行2列的源表格数据到目标表格时，源第一行整行内容会被放入目标第一列，源第二行整行内容放入目标第二列，无法按正确的行列对应关系分布数据。

错误示例：

• 源表格为2行2列数据，粘贴后目标表格第一列两个单元格分别填充源第一、第二行的整行内容，第二列无对应数据
• 正确预期应为源表格的每行每列数据对应填充到目标表格的连续单元格中

Sub PasteDataWithTargetFormat()
    ' This macro pastes data into consecutive cells of an existing table
    ' and adopts the target format of the table.
    
    Dim pptSlide As Slide
    Dim pptShape As Shape
    Dim pptTable As Table
    Dim dataToPaste As String
    Dim dataArray() As String
    Dim i As Integer, j As Integer
    Dim cellIndex As Integer
    Dim startRow As Integer, startCol As Integer
    Dim rowCount As Integer, colCount As Integer
    Dim found As Boolean
    Dim currentRow As Integer, currentCol As Integer
    
    ' Get the active slide
    Set pptSlide = ActiveWindow.View.Slide
    
    ' Loop through all shapes in the slide
    For Each pptShape In pptSlide.Shapes
        ' Check if the shape is a table
        If pptShape.HasTable Then
            Set pptTable = pptShape.Table
            rowCount = pptTable.Rows.Count
            colCount = pptTable.Columns.Count
            
            ' Get the selected cell's row and column
            found = False
            For i = 1 To rowCount
                For j = 1 To colCount
                    If pptTable.Cell(i, j).Selected Then
                        startRow = i
                        startCol = j
                        found = True
                        Exit For
                    End If
                Next j
                If found Then Exit For
            Next i
            
            ' If a cell is selected
            If found Then
                ' Get data from clipboard
                dataToPaste = GetClipboardText()
                
                ' Split the data by line breaks to get multiple lines
                dataArray = Split(dataToPaste, vbCrLf)
                
                ' Initialize the cellIndex
                cellIndex = 0
                
                ' Initialize currentRow and currentCol to start from the selected cell
                currentRow = startRow
                currentCol = startCol
                
                ' Paste data into consecutive cells
                Do While cellIndex <= UBound(dataArray)
                    If currentRow <= rowCount And currentCol <= colCount Then
                        With pptTable.Cell(currentRow, currentCol).Shape.TextFrame.TextRange
                            .Text = dataArray(cellIndex)
                            ' Apply formatting from target cell
                            .Font.Name = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Name
                            .Font.Size = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Size
                            .Font.Bold = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Bold
                            .Font.Italic = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Italic
                            .Font.Underline = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Underline
                            .Font.Color = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Color
                        End With
                        cellIndex = cellIndex + 1
                        ' Move to the next cell
                        currentCol = currentCol + 1
                        If currentCol > colCount Then
                            currentCol = 1
                            currentRow = currentRow + 1
                        End If
                    Else
                        Exit Do
                    End If
                Loop
            Else
                MsgBox "Please select a cell in the table where you want to start pasting the data.", vbExclamation
            End If
        End If
    Next pptShape
End Sub

Function GetClipboardText() As String
    ' This function retrieves text from the clipboard
    Dim DataObj As MSForms.DataObject
    Set DataObj = New MSForms.DataObject
    On Error GoTo ErrorHandler
    DataObj.GetFromClipboard
    GetClipboardText = DataObj.GetText
    Exit Function
ErrorHandler:
    GetClipboardText = ""
    MsgBox "Clipboard is empty or does not contain text.", vbExclamation
End Function

原宏仅按换行符vbCrLf拆分剪贴板数据，未处理表格数据中行内列的分隔符（制表符vbTab），导致整行内容被当作单个单元格值填充，进而造成行列错位。

Sub PasteDataWithTargetFormat()
    ' 将剪贴板表格数据按行列对应粘贴至现有表格，继承目标单元格格式
    
    Dim pptSlide As Slide
    Dim pptShape As Shape
    Dim pptTable As Table
    Dim dataToPaste As String
    Dim rowDataArray() As String
    Dim colDataArray() As String
    Dim i As Integer, j As Integer
    Dim startRow As Integer, startCol As Integer
    Dim rowCount As Integer, colCount As Integer
    Dim found As Boolean
    Dim currentRow As Integer, currentCol As Integer
    
    ' 获取当前幻灯片
    Set pptSlide = ActiveWindow.View.Slide
    
    ' 遍历幻灯片内所有形状
    For Each pptShape In pptSlide.Shapes
        If pptShape.HasTable Then
            Set pptTable = pptShape.Table
            rowCount = pptTable.Rows.Count
            colCount = pptTable.Columns.Count
            
            ' 定位选中的起始单元格
            found = False
            For i = 1 To rowCount
                For j = 1 To colCount
                    If pptTable.Cell(i, j).Selected Then
                        startRow = i
                        startCol = j
                        found = True
                        Exit For
                    End If
                Next j
                If found Then Exit For
            Next i
            
            If found Then
                ' 获取剪贴板文本
                dataToPaste = GetClipboardText()
                If dataToPaste = "" Then Exit Sub
                
                ' 按换行拆分每行数据
                rowDataArray = Split(dataToPaste, vbCrLf)
                
                currentRow = startRow
                currentCol = startCol
                
                ' 遍历每行数据
                For i = LBound(rowDataArray) To UBound(rowDataArray)
                    ' 跳过空行
                    If Trim(rowDataArray(i)) = "" Then GoTo NextRow
                    
                    ' 按制表符拆分当前行的列数据
                    colDataArray = Split(rowDataArray(i), vbTab)
                    
                    ' 遍历当前行的每列数据
                    For j = LBound(colDataArray) To UBound(colDataArray)
                        ' 检查目标单元格是否在表格范围内
                        If currentRow > rowCount Or currentCol > colCount Then GoTo ExitLoop
                        
                        ' 填充数据并继承格式
                        With pptTable.Cell(currentRow, currentCol).Shape.TextFrame.TextRange
                            .Text = colDataArray(j)
                            .Font.Name = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Name
                            .Font.Size = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Size
                            .Font.Bold = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Bold
                            .Font.Italic = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Italic
                            .Font.Underline = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Underline
                            .Font.Color = pptTable.Cell(startRow, startCol).Shape.TextFrame.TextRange.Font.Color
                        End With
                        
                        ' 移动到下一个单元格
                        currentCol = currentCol + 1
                        If currentCol > colCount Then
                            currentCol = 1
                            currentRow = currentRow + 1
                        End If
                    Next j
NextRow:
                Next i
ExitLoop:
            Else
                MsgBox "请先选中表格中要开始粘贴的单元格。", vbExclamation
            End If
        End If
    Next pptShape
End Sub

Function GetClipboardText() As String
    ' 从剪贴板获取文本
    Dim DataObj As MSForms.DataObject
    Set DataObj = New MSForms.DataObject
    On Error GoTo ErrorHandler
    DataObj.GetFromClipboard
    GetClipboardText = DataObj.GetText
    Exit Function
ErrorHandler:
    GetClipboardText = ""
    MsgBox "剪贴板为空或不包含文本内容。", vbExclamation
End Function

内容的提问来源于stack exchange，提问作者Krishna