常用功能加载宏——单元格数据连接

xyj

发布于 2020-07-28 11:38:57

1.9K0

发布于 2020-07-28 11:38:57

文章被收录于专栏：VBA 学习VBA 学习

经常用Excel的人，应该会经常需要把Excel里的数据复制到Word等其他软件中，复制过去经常会碰上格式上的问题。

还有时候需要复制一小块单元格区域，可是复制过去可能就是一个表格，或者是被Tab符号分隔开的内容，并不是真正需要的：

默认从Excel中复制的数据，（如果是复制到Word这类支持表格的软件，会复制表格过去，这个时候还可以进一步转换为文本），列与列之间是使用Tab连接，上一行与下一行是使用换行符连接。

如果列之间的连接符Tab和行之间的连接符换行符可以自定义就好了，那么，我们来实现这么一个复制的功能：

首先在customUI.xml中增加代码：

    <box id="boxCopy" boxStyle="vertical" visible="true">  
     <editBox id="rbtxtRowChar" label="行连接字符:" imageMso="OutlineWeightGallery" keytip="R" sizeString="123456" onChange="rbtxtRowChar_onChange" getText="rbtxtRowChar_getText"/>
     <editBox id="rbtxtColChar" label="列连接字符:" imageMso="TableHeight" keytip="C" sizeString="123456" onChange="rbtxtColChar_onChange" getText="rbtxtColChar_getText"/>
     <button id="rbbtnCopyText" label="复制&#13;" size="large" supertip="复制并连接单元格的Text。" onAction="rbbtnCopyText" imageMso="SizeToFit"/> 
   </box>

回调函数：

Sub rbtxtRowChar_getText(control As IRibbonControl, text)
    text = "newline"
    strRowChar = CheckChar(VBA.CStr(text))
End Sub
Sub rbtxtColChar_getText(control As IRibbonControl, text)
    text = "、"
    strColChar = CheckChar(VBA.CStr(text))
End Sub
Sub rbtxtRowChar_onChange(control As IRibbonControl, text As String)
    strRowChar = CheckChar(text)
End Sub
Sub rbtxtColChar_onChange(control As IRibbonControl, text As String)
    strColChar = CheckChar(text)
End Sub

Private Function CheckChar(text As String) As String
    If VBA.LCase$(text) = "newline" Then
        CheckChar = vbNewLine
    Else
        CheckChar = text
    End If
End Function

Sub rbbtnCopyText(control As IRibbonControl)
    MRange.CopyText strRowChar, strColChar
End Sub

因为我们要自定义列之间的连接符和行之间的连接符，所以需要在MRibbon模块顶部声明2个变量：

Private strRowChar As String
Private strColChar As String

因为换行符不大方便输入，所以设置了一个CheckChar函数，检查如果输入的是文本newline，就会把连接符替换为真正的换行符。

函数实现：

Sub CopyText(strRowChar As String, strColChar As String)
    Dim rng As Range
    Dim str As String
    Dim iRow As Long, iCol As Long
    Dim iRows As Long, iCols As Long
    Dim arrCols() As String
    Dim arrStr() As String
    
    '确保选中的是单元格
    If VBA.TypeName(Selection) = "Range" Then
        Set rng = Selection
        
        If rng.Cells.Count > 1 Then
            '选择的单元格范围的行数
            iRows = rng.Rows.Count
            '选择的单元格范围的列数
            iCols = rng.Columns.Count
            '保存连接后每一行的内容
            ReDim arrStr(iRows - 1) As String
            '记录列单元格的Text
            ReDim arrCols(iCols - 1) As String
            
            For iRow = 0 To iRows - 1
                For iCol = 0 To iCols - 1
                    '记录列单元格的Text，不使用Value属性的目的是因为很多时候Excel的数字会设置特殊格式
                    arrCols(iCol) = rng.Cells(iRow + 1, iCol + 1).text
                Next
                
                '将列单元格的Text连接起来，并存放到arrStr中
                arrStr(iRow) = VBA.Join(arrCols, strColChar)
            Next
            
            '将连接后每一行的内容连接起来
            str = VBA.Join(arrStr, strRowChar)
            
        Else
            str = VBA.CStr(rng.text)
        End If
        
        '复制文本到剪贴板
        SetClipText str
    End If
End Sub

SetClipText函数是一个比较常用的函数，所以可以放到VBAProject文件夹里的vbapFunc.xlam里，然后常用功能加载宏通过工具-引用来使用这个文件：

Sub SetClipText(str As String)
    Dim objData As Object 
    Set objData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    With objData
        .SetText str       '设置文本
        .PutInClipboard
    End With
    Set objData = Nothing
End Sub

本文参与腾讯云自媒体分享计划，分享自微信公众号。

原始发表：2020-06-17，如有侵权请联系 cloudcommunity@tencent.com 删除

xml