参考链接:https://blog.csdn.net/weixin_43144634/article/details/82689732
合并文件夹下各文件
Private Sub hb()
Dim hb As Object, kOne As Boolean, tabcolor As Long
Set hb = Workbooks.Add
Application.DisplayAlerts = False
For I = hb.Sheets.Count To 2 Step -1
hb.Sheets(I).Delete
Next
Dim FileName As String, FilePath As String
Dim iFolder As Object, rwk As Object, Sh As Object
Set iFolder = CreateObject("shell.application").BrowseForFolder(0, "请选择要合并的文件夹", 0, "")
If iFolder Is Nothing Then Exit Sub
FilePath = iFolder.Items.Item.Path
FilePath = IIf(Right(FilePath, 1) = "\", FilePath, FilePath & "\")
FileName = Dir(FilePath & "*.xls*")
Do Until Len(FileName) = 0
If UCase(FilePath & FileName) <> UCase(ThisWorkbook.Path & "\" & ThisWorkbook.Name) Then
Set rwk = Workbooks.Open(FileName:=FilePath & FileName)
tabcolor = Int(Rnd * 56) + 1
With rwk
For Each Sh In .Worksheets
Sh.Copy After:=hb.Sheets(hb.Sheets.Count)
hb.Sheets(hb.Sheets.Count).Name = "小学" & "-" & Sh.Name & "-" & FileName
hb.Sheets(hb.Sheets.Count).Tab.ColorIndex = tabcolor
If Not kOne Then hb.Sheets(1).Delete: kOne = True
Next
.Close True
End With
End If
Set rwk = Nothing
FileName = Dir
Loop
Application.DisplayAlerts = True
'Sort_Sheets
End Sub
Sheet排序
Sub Sort_Sheets()
Dim sCount As Integer, I As Integer, R As Integer
ReDim Na(0) As String '声明数组Na
sCount = Sheets.Count '统计工作表数量。
'------------收集所有工作表名称代码段--------------
For I = 1 To sCount
ReDim Preserve Na(I) As String 'Na被声明为动态数组,数组元素个数随I值发化变化
Na(I) = Sheets(I).Name '将第I个工作表名称存入数组
Next
'------------在数组中对名称进行排序-----------------
For I = 1 To sCount - 1 '从1到工作表数-1
For R = I + 1 To sCount '从i+1到工作表数
If Na(R) < Na(I) Then '若Na(R)<Na(i),将相邻两个数组元素(工作表名称)比较大小。文本也可比大小!
JH = Na(I) '本句和接下来两句,将Na(I)与Na(R)内容互换
Na(I) = Na(R)
Na(R) = JH
End If
Next
Next
'------------根据数组中排好的顺序,将相应工作表移到最后-------完成排序
For I = 1 To sCount '
Sheets(Na(I)).Move After:=Sheets(I)
Next
End Sub
删除无用sheet
'删除名字前三个字符为“sht”的所有工作表
Public Sub delectsh()
Dim c As Worksheet
For Each c In Worksheets
If c.Name like "sht*" Then'这里的“sht”区分大小写
Application.DisplayAlerts = False'删除时不用确认
c.Delete
End If
Next c
End Sub