【1】工作表批量另存为独立的工作簿
Sub 工作表批量另存为独立的工作簿()
Dim oWK As Worksheet
Dim oWB As Workbook
Dim sPath As String
Dim sName As String
If MsgBox('现在开始将把各工作表独立另存为工作簿文件,请再次检查格式数据是否正确?', vbYesNo, '重要提示') = vbYes Then
sPath = Excel.ThisWorkbook.Path
Excel.Application.ScreenUpdating = False
Excel.Application.DisplayAlerts = False
For Each oWK In Excel.ThisWorkbook.Worksheets
With oWK
'将工作表名称作为工作簿的名称保存
sName = .Name
.Copy
Set oWB = Excel.Application.ActiveWorkbook
oWB.SaveAs sPath & '\' & .Name, xlOpenXMLWorkbook
oWB.Close
End With
Next
Excel.Application.ScreenUpdating = True
Excel.Application.DisplayAlerts = True
MsgBox '操作结束'
End If
End Sub
【2】插入图片批注
Sub 插入图片批注()
Dim a
a = MsgBox('使用说明:1、请确认您的图片文件存在与此文件同一目录下的名称为pic的文件夹中。2、选中要添加图片批注的单元格。')
If a = 1 Then
On Error Resume Next
Dim MR As Range
Dim Pics As String
For Each MR In Selection
If Not IsEmpty(MR) Then
MR.Select
MR.AddComment
MR.Comment.Visible = False
MR.Comment.Text Text:=''
MR.Comment.Shape.Fill.UserPicture PictureFile:=ActiveWorkbook.Path & '\pic\' & MR.Value & '.jpg'
End If
Next
End If
End Sub
[3]行列转换
Sub 行转列()
Dim i As Long, j As Long, k As Long
Dim m As Long, n As Long
Dim arr, brr, t
On Error GoTo last
t = Timer
Application.ScreenUpdating = False
Worksheets('【行】数据').Activate
Worksheets('【行】数据').AutoFilterMode = False
Worksheets('【行】数据').Rows('1:1').AutoFilter
ActiveWorkbook.Worksheets('【行】数据').AutoFilter.Sort.SortFields.Add Key:=Range( _
'A1'), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets('【行】数据').AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets('【行】数据').AutoFilterMode = False
Worksheets('【列】数据').Rows('1:1048576').ClearContents
i = 2
m = Worksheets('【行】数据').Cells(1, 1).CurrentRegion.Columns.Count
n = WorksheetFunction.CountA(Worksheets('【行】数据').Range(Cells(1, 2), Cells(WorksheetFunction.CountA(Worksheets('【行】数据').Columns('A:A')), m)))
If n <= 1048580 Then '判断是否超出excel表的行数
ReDim arr(1 To n, 1 To 2)
brr = Worksheets('【行】数据').Cells(1, 1).CurrentRegion.Value
For j = 2 To UBound(brr)
For k = 1 To UBound(brr, 2)
If Len(brr(j, k)) = 0 Then Exit For
If k = 1 Then
arr(i, 1) = brr(j, 1)
k = k + 1
arr(i, 2) = brr(j, k)
Else
i = i + 1
arr(i, 1) = arr(i - 1, 1)
arr(i, 2) = brr(j, k)
End If
Next k
i = i + 1
Application.StatusBar = '正在处理数据:' & j & '行/' & k - 1 & '列'
Next j
Worksheets('【列】数据').Rows('1:1048576').ClearContents
arr(1, 1) = Worksheets('【行】数据').Cells(1, 1).Value
arr(1, 2) = Worksheets('【行】数据').Cells(1, 2).Value
Worksheets('【列】数据').Cells(1, 1).Resize(i, 2) = arr
Worksheets('【列】数据').Activate
Application.StatusBar = '处理完成!'
Erase arr
Erase brr
Else
MsgBox '行转换成列后的数据将超出Excel表行数限制!'
Exit Sub
End If
Application.ScreenUpdating = True
MsgBox '共用时:' & Round(Timer - t, 3) & ' s'
last:
End Sub
联系客服