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