1、按照单元格内容生成文件夹
Sub test()
d = ActiveSheet.Range("b2:b977")
For Each c In d
MkDir "e:MR报告输出文件夹" & c
Next
End Sub
2、从多个表中汇总数据
Sub smergeworkbook()
Dim sPath As String
Dim sName As String
Dim sMsg As String
Dim sMode As String
Dim sFirstFile As String
Dim lFileCount As Long
Dim lRow As Long
Dim iCol As Integer
Dim objWorkbook As Workbook
Dim objSumWk As Workbook
Dim objSumSht As Worksheet
Dim objRng As Range '2- 13行 申明变量
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then
MsgBox "请选择文件目录!", vbInformation, "Excel Home"
Exit Sub
End If
sPath = .SelectedItems(1) & ""
End With '14-21行浏览文件目录
Application.DisplayAlerts = False
If Len(Dir(sPath & "Summary.xlsx")) > 0 Then '判断是否存在
Kill sPath & "Summary.xlsx"
End If
Application.DisplayAlerts = True
sName = Dir(sPath & "*.xlsx") '查找指定目录中的xlsx文件
If Len(sName) > 0 Then
sMsg = "请选择合并方式:" & vbNewLine & vbNewLine & "1 - 合并至工作簿" & vbTab & "2 - 合并至工作表" & vbNewLine & vbNewLine
sMode = Application.InputBox(sMsg, "Excel Home", "1")
If Not (sMode = "1" Or sMode = "2") Then
MsgBox "合并方式错误!", vbInformation, "Excel Home"
Exit Sub
End If
Application.ScreenUpdating = False
sFirstFile = sName
Do
lFileCount = lFileCount + 1 '记录被合并的工作簿个数
Set objWorkbook = Workbooks.Open(sPath & sName) '打开被合并的文件
If objSumWk Is Nothing Then '判断汇总工作簿是否存在
objWorkbook.Worksheets("清单").Activate
objWorkbook.ActiveSheet.Copy
Set objSumWk = ActiveWorkbook
If sMode = "2" Then
Set objSumSht = objSumWk.ActiveSheet
objSumSht.Name = "汇总数据"
End If
Else
If sMode = "1" Then
objWorkbook.ActiveSheet.Copy before:=objSumWk.Sheets(1)
Else
objWorkbook.Worksheets("清单").Activate
With objWorkbook.ActiveSheet
lRow = .Cells(1048576, 1).End(xlUp).Row
iCol = .Cells(4, 16384).End(xlToLeft).Column
If lRow > 3 Then
.Cells(4, 1).Resize(1, iCol).Copy objSumSht.Cells(1048576, 1).End(xlUp).Offset(1, 0)
Application.CutCopyMode = False
End If
End With
End If
End If
objWorkbook.Close False
sName = Dir
Loop While Len(sName) > 0 And sName <> sFirstFile
If Not objSumWk Is Nothing Then
With objSumWk
If sMode = "2" Then
With objSumSht
lRow = .Cells(1048576, 1).End(xlUp).Row
Set objRng = .Cells(2, 1).Resize(lRow - 1, 1)
End With
'objRng.Formula = "=ROW()-1"
'objRng.Formula = objRng.Value
End If
.SaveAs sPath & "summary.xlsx"
.Close
End With
End If
Application.ScreenUpdating = True
If lFileCount > 0 Then
MsgBox "成功合并" & lFileCount & "个数据文件!", vbInformation, "Excel Home"
End If
Else
MsgBox "没有Excel文件!", vbInformation, "Excel Home"
End If
Set objRng = Nothing
Set objSumSht = Nothing
Set objWorkbook = Nothing
Set objSumWk = Nothing
End Sub
3、隔行插入
Sub 隔行插入()
Dim r%
Do
r = r + 2
Rows(r).Insert
Loop Until Cells(r + 1, 1) = ""
End Sub
4、隔行删除
Sub 隔行删除()
Dim r, s
m = Application.CountA(Columns(1))
For r = 1 To m / 2
Rows(r).Delete
Next
End Sub
5、根据查找功能拾取的颜色求平均
Sub 根据查找功能拾取的颜色求平均()
On Error GoTo 100
Dim erng As Range, rng As Range, i As Long
i = Application.FindFormat.Interior.Color
Set erng = Cells(Rows.Count, "e").End(xlUp)
For Each rng In Range([b2], erng)
If rng.Interior.Color = i Then k = k + rng.Value: n = n + 1
Next
MsgBox "最后平均分为：" & k / n & "分"
End
100:
MsgBox "查找功能没有拾取到颜色！"
End Sub
6、合并单元格时连接每个单元格内容
Sub mergecells()
Dim mergestr As String
Dim mergerng As Range
Dim rng As Range
Set mergerng = Range("A1:B2")
For Each rng In mergerng
mergestr = mergestr & rng & ""
Next
Application.DisplayAlerts = False
mergerng.Merge
mergerng.Value = mergestr
Application.DisplayAlerts = True
Set mergerng = Nothing
Set rng = Nothing
End Sub
7、合并内容相同的单元格
Sub 合并内容相同的单元格()
Dim r As Integer
Dim i As Integer
Application.DisplayAlerts = False
With Sheet1
r = .Cells(Row.Count, 1).End(xlUp).Row
For i = r To 2 Step -1
If .Cells(i, 2).Value = .Cells(i - 1, 2).Value Then
.Range(.Cells(i - 1, 2), .Cells(i, 2)).Merge
End If
Next
End With
Application.DisplayAlerts = True
End Sub
8、是否包含合并单元格
Sub ismergecells()
If IsNull(Range("A1:D10").MergeCells) Then
MsgBox "包含合并单元格", vbInformation
Else
MsgBox "没有包含合并单元格", vbInformation
End If
End Sub
9、删除空行
Sub test1()
Dim rng As Range, ads As String
For Each rng In [a1:a10]
If rng = "" Then ad = ad & rng.Address & ","
Next
ads = Left(ad, Len(ad) - 1)
Range(ads).EntireRow.Delete
End Sub
10、提取文件夹下文件名及路径
Dim arr(), i
Sub 创建文件目录()
Dim PathStr As String
With Application.FileDialog(msoFileDialogFolderPicker) '创建一个选择文件夹的对话框
If .Show = True Then PathStr = .SelectedItems(1) Else Exit Sub
End With
If Right(PathStr, 1) <> "" Then PathStr = PathStr & "" '如果路径没有""，则追加一个""
Cells.Clear
Application.ScreenUpdating = False
Call 查找(PathStr)
If i > 0 Then '如果文件大于0，从A2开始，在i行3列的区域存放查找结果
Range("a2").Resize(i, 3) = WorksheetFunction.Transpose(arr)
Range("a1:c1") = Array("路径", "文件名", "大小（MB）")
Range("a:c").EntireColumn.AutoFit '自动调整宽度
Range("c:c").NumberFormat = "0.00"
End If
Application.ScreenUpdating = True
End Sub
Private Sub 查找(路径 As String)
Dim dirs() As String, dir_count As Long, dir_name As String, dir_name_2 As String, j
If Right(路径, 1) <> "" Then 路径 = 路径 & ""
dir_name = Dir(路径 & "*.*", vbDirectory) '获取文件的名称（可能文件可能文件夹）
Do While Len(dir_name) <> 0
If Left$(dir_name, 1) <> "." Then '如果左边第一个字符不是"."（排除父级目录）
dir_name_2 = 路径 & dir_name
If (GetAttr(dir_name_2) And vbDirectory) = vbDirectory Then
dir_count = dir_count + 1
ReDim Preserve dirs(1 To dir_count) As String
dirs(dir_count) = dir_name_2
Else
i = i + 1
ReDim Preserve arr(1 To 3, 1 To i)
arr(1, i) = 路径
arr(2, i) = dir_name
arr(3, i) = FileLen(路径 & dir_name) / 1024 / 1024
关注楼主