实用vba案例

2023-08-19 02:59| 来源: 网络整理| 查看: 265

拆分sheet

每个sheet存到一个新文件中

Sub chaifen() Dim sht As Worksheet Dim MyBook As Workbook Set MyBook = ActiveWorkbook For Each sht In MyBook.Sheets sht.Copy ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & MyBook.Name & "_" & sht.Name & ".xls" ActiveWorkbook.Close Next MsgBox "文件已经被分拆完毕!" End Sub 拆分行

文件行数太多，按照每20行进行切割，切割后存到新的excel表中。

Sub splitRow() Application.ScreenUpdating = False p = ActiveWorkbook.Path & "\" With ActiveSheet For r = 1 To .Range("a1048576").End(xlUp).Row Step 20 Set wb = Workbooks.Add .Rows(r).Resize(30).Copy wb.Sheets(1).Cells(1) wb.SaveAs p & r & ".xls", xlNormal wb.Close Next End With Application.ScreenUpdating = True End Sub 根据单元格创建sheet

循环目标区域，如果对应名字的sheet已经有了，就不创建，否则创建对应的sheet

Sub process() Dim sht As Worksheet Dim i, k As Integer For Each rag In Range("d2:d1000") k = 0 For Each sht In Sheets If rag.Value = sht.Name Then k = 1 Exit For End If Next If k = 0 Then Sheets.Add after:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = rag End If Next End Sub 目标区域复制到其他sheet Sub copytosheet() For i = 2 To Sheets.Count Sheets(1).Range("a1").Copy Sheets(i).Range("a1") Next End Sub 对整个文件夹内的所有文件处理

下面的案例，扫描目标文件夹内所有的xlsx文件，然后执行processEach过程。 processEach过程会打开这个文件，对文件执行mysplit，然后保存关闭。 mysplit过程会把文件拆开，放到文件所在位置的子文件夹内。

整个代码的作用：把strPath下的所有xlsx文件切割，切割的规则是每30行切一次。切割出来的文件放在全部strPath/target下。

Sub ListFiles() Dim strPath As String, strTmp As String Dim originbook As Workbook strPath = "C:\test\" strTmp = Dir(strPath & "*.xlsx") i = 1 Do While strTmp "" Call processEach(strPath, strTmp) strTmp = Dir i = i + 1 Loop End Sub Sub processEach(filepath As String, filename As String) Workbooks.Open filepath & filename With ActiveSheet Call mysplit(30) End With Workbooks(filename).Save Workbooks(filename).Close End Sub Sub mysplit(m As Integer) Application.ScreenUpdating = False p = ActiveWorkbook.Path & "\target\" On Error Resume Next VBA.MkDir p fn = ActiveWorkbook.Name With ActiveSheet For r = 1 To .Range("a1048576").End(xlUp).Row Step m Set wb = Workbooks.Add .Rows(r).Resize(m).Copy wb.Sheets(1).Cells(1) wb.SaveAs p & fn & "_" & r & ".xlsx" wb.Close Next End With Application.ScreenUpdating = True End Sub

【本文地址】

实用vba案例

实用vba案例

今日新闻

推荐新闻