别怕VBA其实很简单 抄录；一个一个字母打的。
很好用，表的批量操作
Step1:批量新建工作表 Shtadd()
Step2:批量数据分类 Fenlei(), (must after step 1 )
Step3:Sheet数据拆分到新工作薄 savetofile ()
Step4:快速合并多表数据 hebing()
Step5:合并同文件夹下多工作薄数据 HzwWb()
Step6:Sheet 索引目录 mulu()
###############################
#############################
Subwbadd()
Dimwb As Workbook, sht As Worksheet
Setwb = Workbooks.Add
Setsht = wb.Worksheets(1)
Withsht
.Name= "test001"
.Range("A1:f1")= Array("ad", "asdgf", "lkjg", "rfg","hg", "lk")
EndWith
wb.SaveAsThisWorkbook.Path & "\test001111.xlsx"
ActiveWorkbook.Close
EndSub
----------------------
Subisopen()
Dim i As Integer
For i = 1 To Workbooks.Count
If Workbooks(i).Name = "test001111.xlsx" Then
MsgBox " opend"
Exit Sub
End If
Next
MsgBox " not open"
EndSub
--------------------
Subshttest_1()
Dimsht As Worksheet
ForEach sht In Worksheets
If sht.Name = "adsg" Then
sht.Move before:=Worksheets()
Exit Sub
End If
Next
Worksheets.Add(before:=Worksheets(1)).Name= "adsg"
EndSub
--------------------------------------------
Subtestfile()
Dimfil As String
fil= ThisWorkbook.Path & "test001111.xlsx"
IfLen(Dir(fil)) > 0 Then
MsgBox "workbook exist"
Else
MsgBox "workbook doesnt exist"
EndIf
EndSub
-------------------------------------------
Subshtadd()
Dim i As Integer, sht As Worksheet
i = 2
Set sht = Worksheets("adsg")
Do While sht.Cells(i, "C") <> ""
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sht.Cells(i, "C").Value
i = i + 1
Loop
EndSub
----------------------------------------------------
Subfenlei()
Dim i As Long, bj As String, rng As Range
i = 2
bj = Cells(i, "C").Value
Do While bj <> ""
Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)
Cells(i, "A").Resize(1, 7).Copy rng
i = i + 1
bj = Cells(i, "C").Value
Loop
EndSub
----------------------------------------------
Subshtclear()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name <> "test001111.xlsx" Then
sht.Range("A2:G65536").ClearContents
End If
Next
EndSub
Subtest1()
EndSub
--------------------------------------------------
Subtest2()
EndSub
Subasdgg()
Dim i As Long, bj As String, rng As Range
i = 2
bj = Cells(i, "C").Value
Do While bj <> ""
Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)
Cells(i, "A").Resize(1, 5).Copy rng
i = i + 1
bj = Cells(i, "C").Value
Loop
EndSub
-------------------------------------
Subshtclear()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name <> "test001111.xlsx" Then
sht.Range("A2:G65536").ClearContents
End If
Next
EndSub
-------------------------------------------------------------
Subsavetofile()
Application.ScreenUpdating = False
Dim folder As String
folder = ThisWorkbook.Path & "\test00223"
If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
Dim sht As Worksheet
For Each sht In Worksheets
sht.Copy
ActiveWorkbook.SaveAs folder & "\" & sht.Name &".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
EndSub
------------------------------------------------------
Submerge()
Rows("2:65536").Clear
Dim sht As Worksheet, xrow As Integer, rng As Range
For Each sht In Worksheets
If sht.Name <> ActiveSheet.Name Then
Set rng = Range("A65536").End(xlUp).Offset(1, 0)
xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1
sht.Range("A2").Resize(xrow, 7).Copy rng
End If
Next
EndSub
------------------------------------------------
Submerge()
Rows("2:65536").Clear
Dim sht As Worksheet, xrow As Integer, rng As Range
For Each sht In Worksheets
If sht.Name <> ActiveSheet.Name Then
Set rng = Range("A65536").End(xlUp).Offset(1, 0)
xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1
sht.Range("A2").Resize(xrow, 3).Copy rng
End If
Next
EndSub
-------------------------------------------------
Subhebing()
Rows("2:65536").Clear
Dim sht As Worksheet, xrow As Integer, rng As Range
For Each sht In Worksheets
If sht.Name <> ActiveSheet.Name Then
Set rng = Range("A65536").End(xlUp).Offset(1, 0)
xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1
sht.Range("A2").Resize(xrow, 7).Copy rng
‘列数
End If
Next
EndSub
--------------------
Submulu()
Rows("2:65536").ClearContents
Dim sht As Worksheet, irow As Integer
irow = 2
For Each sht In Worksheets
Cells(irow, "A").Value = irow - 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(irow, "B"),Address:="", _
SubAddress:="'" & sht.Name & "'!A1",TextToDisplay:=sht.Name
irow = irow + 1
Next
EndSub
-------------------------------------------------------
Subhzwb()
Dim r As Long, c As Long
r = 1
c = 8
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents
Application.ScreenUpdating = False
Dim filename As String, wb As Workbook, sht As Worksheet, erow As Long, _
fn As String, arr As Variant
filename = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While filename <> ""
If filename <> ThisWorkbook.Name Then
erow = Range("A1").CurrentRegion.Rows.Count + 1
fn = ThisWorkbook.Path & "\" & filename
Set wb = GetObject(fn)
Set sht = wb.Worksheets(1)
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536,"B").End(xlUp).Offset(0, 8))
Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close
End If
filename = Dir
Loop
Application.ScreenUpdating = True
EndSub