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