Sub SplitWk(control As IRibbonControl) '将工作簿的每一个工作表存为单独的工作簿
'定义变量
Dim sht, sht2 As Worksheet
Dim wk As Workbook
Dim path, wkpath As String
Application.DisplayAlerts = False '关闭程序警告
Application.ScreenUpdating = False '关闭屏幕更新
path = GetPath '打开文件对话框获取一个文件夹路径
For Each sht In ActiveWorkbook.Worksheets '遍历每一个工作表
wkpath = path & sht.Name & ".xlsx" '设置存储路径
Set wk = Workbooks.Add '新建一个工作簿
sht.Copy before:=wk.Sheets(1) '将一个工作表复制到新建的工作簿的第一个工作表之前
For Each sht2 In wk.Sheets
If sht2.Name sht.Name Then
sht2.Delete '删除新工作簿中的不要的工作表
End If
Next
wk.SaveAs wkpath '保存新的工作簿
wk.Close '关闭新的工作簿
Next
MsgBox "拆分成功！" '弹出一个消息框，显示拆分成功！
Application.ScreenUpdating = True '关闭程序警告
Application.DisplayAlerts = True '关闭屏幕更新
End Sub
Sub GetAllData(control As IRibbonControl) '汇总多个同结构文件数据 利用数据透视表去重
Dim path, Str, wkpath, RngAds As String
Dim AP As New Excel.Application
Dim Wb As Workbook
Dim wt As Worksheet
Dim rng As Range
Dim Arr()
Dim Rn As Integer
path = GetPath
Range("A1:C1") = Array("序号", "产品", "销量")
Str = Dir(path) '获取选中文件夹下包含的文件的名字
Do While Str "" '开始循环获取文件名
wkpath = path & Str '得到文件的路径
Set Wb = AP.Workbooks.Open(wkpath) '打开工作簿
Set wt = Wb.Sheets(1) '获取第一个工作表
Rn = wt.Cells(Rows.Count, 1).End(xlUp).Row '获取第一个工作表的第一列的最后的使用过的行
RngAds = Range(Cells(2, 1), Cells(Rn, 2)).Address '获取单元格的地址
Arr = wt.Range(RngAds) '用数组存储单元格的数据
Rn = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(Rn, 2).Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr '将获取的数据写入当前工作表
Str = Dir
Wb.Close
Loop
Rn = Cells(Rows.Count, 2).End(xlUp).Row
For Each rng In Range(Cells(2, 1), Cells(Rn, 1))
rng = rng.Row - 1 '编制序号
Next
MsgBox "汇总完成!", vbOKCancel, "大佬你好"
End Sub
Sub 图片导入(control As IRibbonControl)
Dim path, Str, picpath As String
Dim w, h, l, t As Double
Dim rng As Range
Dim n As Integer
path = GetPath
Str = Dir(path)
n = 1
Do While Str ""
n = n + 1
Set rng = Cells(n, 1)
With rng
w = .Width
h = .Height
l = .Left
t = .Top
End With
picpath = path & Str
ActiveSheet.Shapes.AddPicture picpath, True, True, l, t, w, h
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select
Selection.Placement = xlMoveAndSize
Str = Dir
Loop
End Sub
Sub 图片处理宽度大小(control As IRibbonControl) '处理图片的大小和宽度
Dim sh As Shape
Dim w, h, lt, tt, wdif, hdif As Double
Dim n As Integer
w = 400 '图片宽度
h = 0.5 * w '图片高度
wdif = 20
hdif = 20
For Each sh In ActiveSheet.Shapes
n = n + 1
sh.LockAspectRatio = msoFalse '取消图片的锁定纵横比
sh.Width = w
sh.Height = h
If n Mod 2 = 0 Then
lt = w + 2 * wdif
Else
lt = wdif
tt = (h + hdif) * (n - 1) * 0.5 + hdif
End If
sh.Left = lt '设置图片左上角距离原点X的距离
sh.Top = tt '设置图片左上角距离原点Y的距离
Next
End Sub
Sub 图片导出(control As IRibbonControl)
Dim path As String
Dim sh As Shape
Dim n, m As Integer
Dim mychart As Chart
path = GetPath
For Each sh In ActiveSheet.Shapes '遍历工作表里的所有图片
n = n + 1
For m = 1 To 20
sh.Select
Selection.CopyPicture
Set mychart = ActiveSheet.ChartObjects.Add(0, 0, Selection.Width - 2, Selection.Height - 2).Chart '将图片创建为一个图表
With mychart
.Paste
.Export path & m & ".jpg" '导出图片
.Parent.Delete '删除图表
End With
Next
Exit For
Next
MsgBox "导出完成"
End Sub
|
|
转播
