Excel_常规表操作总结_亲自跑过程序可用

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