Excel VBA

================

Sub 下拉()
Application.ScreenUpdating = False
Dim mybook As Workbook
Set mybook = Workbooks("彙總.xlsx")
Dim target As Workbook
Workbooks.Open "C:\Users\jacky\Desktop\政策落地執行表\李曉.xlsx"
Set target = Workbooks("李曉.xlsx")
target.Sheets("申蓉聖飛").Cells.Copy mybook.Sheets("sheet2").Cells
Set mybook = Nothing
Set target = Nothing
Workbooks("李曉.xlsx").Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub

===================

Sub 工做簿拆分()
Dim wb As Workbook, sh As Worksheet
For Each sh In Worksheets '遍歷全部工做表
sh.Copy '複製工做表
Set wb = ActiveWorkbook '到新的工做簿
k = sh.Name '計數 '注：此行也可寫成k=sh.name 若是這樣寫，則下行中漢字去掉。
wb.SaveAs ThisWorkbook.Path & "/" & k & ".xlsx" '在本文件路徑中保存工做簿
wb.Close '關閉建立的工做簿
Next
End Sub

 

=========

Sub 拆分爲獨立工做薄()
Application.ScreenUpdating = False
Dim wb, wb1 As Excel.Workbook
Dim sh As Excel.Worksheet
f = Dir(ThisWorkbook.Path & "\初始表" & "\*.xls*") '生成查找EXCEL的目錄,能夠適應不一樣版本
Do While f <> "" And f <> ThisWorkbook.Name '在目錄中循環
Set wb = Workbooks.Open(ThisWorkbook.Path & "\初始表\" & f) '依次打開目錄工做薄
For Each sh In wb.Worksheets '在打開的工做薄的工做表中循環
sh.Copy '拷貝工做表爲工做薄
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\已拆分\" & sh.Name & ".xlsx" '工做表保存爲工做薄

ActiveWorkbook.Close '關閉新創建的工做薄
Next

wb.Close False '關閉打開的工做薄
f = Dir()
Loop '結束循環
Application.ScreenUpdating = True
End Sub

－－－－－－－－

Option Explicit
Sub hbgzb()
Dim sh As Worksheet, flag As Boolean, i As Integer, hrow As Integer, hrowc As Integer
For i = 1 To Sheets.Count
If Sheets(i).Name = "合併數據" Then flag = True
Next
If flag = False Then
Set sh = Worksheets.Add
sh.Name = "合併數據"
Sheets("合併數據").Move after:=Sheets(Sheets.Count)
End If
For i = 1 To Sheets.Count
If Sheets(i).Name <> "合併數據" Then
hrow = Sheets("合併數據").UsedRange.Row
hrowc = Sheets("合併數據").UsedRange.Rows.Count
If hrowc = 1 Then
Sheets(i).UsedRange.Copy Sheets("合併數據").Cells(hrow, 1).End(xlUp)
Else
Sheets(i).UsedRange.Copy Sheets("合併數據").Cells(hrow + hrowc - 1, 1).Offset(1, 0)
End If
End If
Next i
End Sub