|
发表于 2011-4-22 20:50
|
显示全部楼层
本楼为最佳答案
回复 tayisha 的帖子
- Sub 拆分工作薄()
- Application.ScreenUpdating = False
- Call 拆分工作表
- Dim fd As FileDialog, path As String, sht As Worksheet
- Set fd = Application.FileDialog(msoFileDialogFolderPicker)
- If fd.Show = -1 Then
- path = fd.SelectedItems(1) & IIf(Right(fd.SelectedItems(1), 1) = "", "", "")
- Else: Exit Sub
- End If
- For Each sht In Sheets
- sht.Copy
- ActiveWorkbook.SaveAs path & sht.Name, xlWorkbookDefault
- ActiveWorkbook.Close
- Next sht
- Application.ScreenUpdating = True
- End Sub
- Sub 拆分工作表()
- Dim sht As Worksheet, bm As String
- Dim Rng1 As Range, Rng2 As Range
- Set Rng1 = Range("A1").Resize(1, 8)
- K = [B65536].End(xlUp).Row
- For Ro = 2 To [A65536].End(xlUp).Row
- bm = Cells(Ro, 1)
- i = Ro
- Do
- i = i + 1
- If i > K Then
- Exit Do
- End If
- Loop Until Cells(i, 1) <> ""
- Set Rng2 = Range("A" & Ro).Resize(i - Ro, 8)
- Set Rng2 = Union(Rng1, Rng2)
- Set sht = Sheets.Add
- sht.Name = bm
- Rng2.Copy Sheets(bm).[A1]
- Sheets("所属各地分公司").Select
- Ro = i - 1
- Next Ro
- End Sub
复制代码 费了九牛二虎之力终于弄出来了:满意的话还是评一个最佳把
拆分工作薄.rar
(12.37 KB, 下载次数: 23)
|
|