Question

我正在一个项目中工作，我必须使用Crt A + Crt C从网页复制一些文本，然后我想在Excel中使用此数据复制的文本大约是100行，具有不同的大小，让我们说在线有一个200字符串的字符串，下一个有500图表。而第3个可能是20个有没有办法循环剪贴板数据行并将它们复制到数组？

我添加复制的样本（在页面中制作Crt A Crt C）文本：

注意：我删除了一些行

用户名是XXXXXXXXXXXXXXXXX DashboardAnalyticsPolicyAdministration 网络见解打印视图重来 1选择图表类型日志应用过滤器 2选择一个时间表自定义：9/1/2015 12:00:00 AM - 9/30/2015 12:00:00 AM 3选择过滤器添加过滤器 2.4 TB 2.0 TB 879.9 GB 656.8 GB 472.0 GB 442.4 GB 242.1 GB 213.5 GB 189.3 GB 103.8 GB Office 365 - SSL旁路专业的服务流媒体网站所有人互联网服务企业营销杂网络搜索新闻和媒体社交网络 URL CategoryTop 10TransactionsBytes 注意：如果将此文本粘贴到记事本，您将逐行看到它

Answer 1

要跟进我的评论，如果您按照here中的说明添加对Microsoft Forms Library 2.0的引用（在VBA编辑器中的Tools/References下），则以下函数将使用以下内容：剪贴板并将其拆分为行：

Function ClipToArray() As Variant
    Dim clip As New MSForms.DataObject
    Dim lines As String
    clip.GetFromClipboard
    lines = clip.GetText
    lines = Replace(lines, vbCr, "")
    ClipToArray = Split(lines, vbLf)
End Function

你可以这样测试：

Sub test()
    Dim A As Variant
    Dim i As Long
    A = ClipToArray()
    For i = LBound(A) To UBound(A)
        Debug.Print A(i)
    Next i
End Sub

然后我去了this网站并复制了这首诗，然后跑了test。我在即时窗口中得到以下输出：

Some say the world will end in fire,
Some say in ice.
From what I've tasted of desire
I hold with those who favor fire.
But if it had to perish twice,
I think I know enough of hate
To say that for destruction ice
Is also great
And would suffice.

这很好用，但是在你看到使用split的表面解析还有很多不足之处之前你不必用互联网上复制的文本进行很多实验。

Answer 2

我是为那些想要从复制范围中提取2D信息的人设计的。

'Display the content of the clipboard
Sub test()
    Dim A As Variant
    Dim i As Long
    A = ClipToArray()
    For i = LBound(A, 1) To UBound(A, 1)
        tmp = ""
        For j = LBound(A, 2) To UBound(A, 2)
            tmp = tmp & A(i, j) & "  |  "
        Next
        Debug.Print tmp
    Next
End Sub

'Made by LePatay on 2018/12/07
'Extract a 2D array from a copied 2D range
Function ClipToArray()
    'Include Tools -> References -> Microsoft Forms 2.0 Object Library
    'or you will get a "Compile error: user-defined type not defined"
    Dim dataobj As New MSForms.DataObject
    Dim array2Dfitted As Variant
    Dim cbString As String
    'Special characters
    quote = """"
    tabkey = vbTab
    CarrReturn = vbCr
    LineFeed = vbLf
    'Get the string stored in the clipboard
    dataobj.GetFromClipboard
    On Error GoTo TheEnd
    cbString = dataobj.GetText
    On Error GoTo 0
    'Note: inside a cell, you only find "vbLf";
    'at the end of each row, you find "vbCrLf", which is actually "vbCr & vbLf".
    cbString = Replace(cbString, vbCrLf, CarrReturn)
    'Length of the string
    nbChar = Len(cbString)
    'Get the number of rows
    nbRows = Application.Max(1, nbChar - Len(Replace(cbString, CarrReturn, "")))
    'Get the maximum number of columns possible
    nbColumnsMax = nbChar - Len(Replace(cbString, tabkey, "")) + 1
    'Initialise a 2D array
    Dim array2D As Variant
    ReDim array2D(1 To nbRows, 1 To nbColumnsMax)
    'Initial position in array2D (1st cell)
    curRow = 1
    curColumn = 1
    'Initialise the actual number of columns
    nbColumns = curColumn
    'Initialise the previous character
    prevChar = ""
    'Browse the string
    For i = 1 To nbChar
        'Boolean "copy the character"
        bCopy = True
        'Boolean "reinitialise the previous character"
        bResetPrev = False
        'For each character
        curChar = Mid(cbString, i, 1)
        Select Case curChar
            'If it's a quote
            Case quote:
                'If the previous character is a quote
                If prevChar = quote Then
                    'Indicates that the previous character must be reinitialised
                    '(in case of a succession of quotes)
                    bResetPrev = True
                Else
                    'Indicates the character must not be copied
                    bCopy = False
                End If
            'If it's a tab
            Case tabkey:
                'Indicates the character must not be copied
                bCopy = False
                'Skip to the next column
                curColumn = curColumn + 1
                'Updates the actual number of columns
                nbColumns = Application.Max(curColumn, nbColumns)
            'If it's a carriage return
            Case CarrReturn:
                'Indicates the character must not be copied
                bCopy = False
                'If it's not the 1st character
                If i > 1 Then
                    'Skip to the next row
                    curRow = curRow + 1
                    curColumn = 1
                End If
        End Select
        'If the character must be copied
        If bCopy Then
            'Adds the character to the current cell
            array2D(curRow, curColumn) = array2D(curRow, curColumn) & curChar
        End If
        'If the previous character must be reinitialised
        If bResetPrev Then
            prevChar = ""
        Else
            'Saves the character
            prevChar = curChar
        End If
    Next
    'Create a 2D array with the correct dimensions
    ReDim array2Dfitted(1 To nbRows, 1 To nbColumns)
    'Copies the data from the big array to the fitted one (no useless columns)
    For r = 1 To nbRows
        For c = 1 To nbColumns
            array2Dfitted(r, c) = array2D(r, c)
        Next
    Next
TheEnd:
    ClipToArray = array2Dfitted
End Function

备注：

无法确定单元格是否已合并。
此代码对于引用，引用的连续以及单元格中的多行具有鲁棒性。
它已在法语Excel Win 7 64位上进行了测试。报价/回车/换行的系统在您的操作系统上可能会有所不同。

VBA Excel将剪贴板数据复制到数组

注意：我删除了一些行

2 个答案: