Excel VB 脚本集

合并多个工作薄的 sheet 到一个工作薄

Sub 合并多个excle文件到一个文件sheets2one()
'定义对话框变量
Dim cc As FileDialog
Set cc = Application.FileDialog(msoFileDialogFilePicker)
Dim newwork As Workbook
Set newwork = Workbooks.Add
With cc
If .Show = -1 Then
Dim vrtSelectedItem As Variant
Dim i As Integer
i = 1
For Each vrtSelectedItem In .SelectedItems
Dim tempwb As Workbook
Set tempwb = Workbooks.Open(vrtSelectedItem)
tempwb.Worksheets(1).Copy Before:=newwork.Worksheets(i)
newwork.Worksheets(i).Name = VBA.Replace(tempwb.Name, ".xls", "")
tempwb.Close SaveChanges:=False
i = i + 1
Next vrtSelectedItem
End If
End With
Set cc = Nothing
End Sub
​

合并当前工作簿下的所有工作表

Sub 合并当前工作簿下的所有工作表()
Dim ws As Worksheet
Dim sh As Worksheet, i%
On Error Resume Next '如遇错误继续运行
Application.ScreenUpdating = False '关闭屏幕刷新
Application.DisplayAlerts = False '禁用警告提示
Worksheets("汇总").Delete '删除原汇总表
Set ws = Worksheets.Add(before:=Sheets(1)) '新建工作表
ws.Name = "汇总" '新建工作表命名为汇总
For Each sh In Sheets: '遍历所有工作表
If sh.Name <> "汇总" Then '判断工作表是否为汇总表
i = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 '获取汇总表中A列数据区域最后一行的行号+1
sh.UsedRange.Copy '复制分表中的数据
ws.Cells(i, 1).PasteSpecial Paste:=xlPasteAll '粘贴数据
ws.Cells(i, 1).PasteSpecial Paste:=xlPasteColumnWidths '粘贴列宽
End If
Next
Application.DisplayAlerts = True '恢复警告提示
Application.ScreenUpdating = True '开启屏幕刷新
MsgBox "工作表合并完毕"
End Sub
​

工作表中图片 url 链接替换成图片

With Target
        If Left(.Value, 7) = "http://" Then '如果单元格内容为网址
            '添加网络图片，并设置为图片大小位置随单元格变化而变化
            ActiveSheet.Shapes.AddPicture(.Value, msoCTrue, msoCTrue, .Left, .Top, .Width, .Height).Placement = xlMoveAndSize
            .WrapText = True '单元格设置为自动换行，以隐藏网址
        End If
End With
​