博客

'将文本复制到剪贴板
Sub copyToClipbox(strText As String, Optional noMsg As Boolean)
    
    On Error Resume Next
    
    '1C3B4210-F441-11CE-B9EA-00AA006B1A69 是标识符，通俗点说就是COM对象的身份证号码。
    '明确的称呼是 GUID（Globally Unique Identifier的简称，中文翻译为“全局唯一标示符”）,在Windows系统中也称之为Class ID，缩写为CLSID。
    '至于这串标识符所代表的某COM对象长啥样，你可以打开注册表编辑器（regedit），以这串字符串为关键字，就会得到结果
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText strText
        .PutInClipboard
    End With
    
    On Error GoTo 0
    
    If noMsg = False Then
        MsgBox "语句已经复制到剪贴板", vbInformation, "友情提示"
    End If
    
End Sub

'循环当前工作簿的所有工作表，将其他sheet数据复制到同一sheet
Sub cycleExcel()
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ThisWorkbook.Activate
    
    Dim STRNAME As String
    Dim I As Integer, j As Integer
    j = 3
    I = 0
    
    STRNAME = ""
    
    On Error Resume Next
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> Worksheets("目录").Name Then
            sh.Select
                        
            Set Rng = Range("A1")

            lastRow = Cells(Rows.Count, 1).End(xlUp).Row
            lastColumn = Rng.End(xlToRight).Column
            If lastRow = 1 Or lastRow > 10000 Or lastColumn > 256 Then MsgBox "行或列没有，或者过多", vbInformation, "友情提示"

            '列数组
            'arrColumn = Range(Cells(3, 2), Cells(lastRow, lastColumn))
            'For i = LBound(arrColumn) To UBound(arrColumn)
            
            I = j + lastRow

            sh.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Copy Worksheets("目录").Range("A" & j)
            'Worksheets("目录").Paste
            j = j + lastRow
            
            STRNAME = STRNAME & vbLf & Cells(1, 2) & "   lastRow, lastColumn  " & lastRow & "," & lastColumn & "  " & sh.Name & "   I, J  " & I & j
            
        End If
    Next
    
    Call copyToClipbox(STRNAME, False)
    
    Worksheets("目录").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

'按照列表对sheet进行排序
Sub ExcelOrder()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Worksheets("目录").Select
    
    Dim sheetname As String, sheetna As String
    Dim I As Integer

    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    On Error GoTo 100
    For I = 2 To lastRow
        sheetname = Worksheets("目录").Cells(I, 5).Value
        If I = 2 Then
            Sheets(sheetname).Move AFTER:=Sheets("目录")
        Else
            Sheets(sheetname).Move AFTER:=Sheets(sheetna)
        End If
    
        sheetna = sheetname
    
    Next

    Worksheets("目录").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "工作表排序完成", vbInformation, "友情提示"
    Exit Sub
    
100:
    MsgBox "第 " & I & "行，工作表：" & sheetname & "不存在", vbInformation, "友情提示"
    Worksheets("目录").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
'批量添加超链接
Sub sheetAddHyperlink()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Worksheets("目录").Select
    
    Dim sheetname As String
    Dim I As Integer, num As Integer

    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    On Error GoTo 100
    For I = 2 To lastRow
        sheetname = Worksheets("目录").Cells(I, 5).Value
        If Sheets(sheetname) Is Nothing Then
            num = Worksheets("目录").Cells(I, 5).Hyperlinks.Count
            If num > 0 Then Worksheets("目录").Cells(I, 5).Hyperlinks.Delete
        End If
        
        Worksheets("目录").Cells(I, 5).Hyperlinks.Add Anchor:=Worksheets("目录").Cells(I, 5), Address:="", SubAddress:=Worksheets("目录").Cells(I, 5).Value + "!A1", TextToDisplay:=Worksheets("目录").Cells(I, 5).Value
        
    Next

    Worksheets("目录").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "工作表添加超链接完成", vbInformation, "友情提示"
    Exit Sub
    
100:
    MsgBox "第 " & I & "行，工作表：" & sheetname & "不存在", vbInformation, "友情提示"
    Worksheets("目录").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub