|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub 按钮1_Click()
- Application.ScreenUpdating = False
- Set sh = ActiveSheet
- Sheets.Add after:=Sheets(1)
- For J = 1 To sh.Cells(Rows.Count, 1).End(3).Row
- If InStr(sh.Cells(J, 1), "机构名称:") > 0 Then
- Sheets(2).UsedRange.Clear
- sh.Cells(J, 1).CurrentRegion.Copy Sheets(2).[a1]
- Sheets(2).Name = sh.Cells(J, 3)
- Sheets(2).Copy
- With ActiveWorkbook
- .SaveAs ThisWorkbook.Path & "" & sh.Cells(J, 3) & ".xlsx"
- .Close False
- End With
- End If
- Next J
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|