VBA实战二---将总数据表进行拆分至多个工作表

将总数据表进行拆分至多个工作表

问题

将数据表中数据根据所属部门分配至对应部门的工作表内,如下图所示:
在这里插入图片描述
在这里插入图片描述

使用For循环拆分工作表

Sub shishi()

Dim sht As Worksheet
Dim rng As Range

Call qk

'循环每个表
For Each sht In Sheets
       
    '循环第一张表中每一行
    For Each rng In Sheet1.Range("d2:d" & Sheet1.Range("d65535").End(xlUp).Row)
    
        If sht.Name = "数据" Then
            Exit For
        End If
 
        If rng.Value = sht.Name Then
            rng.EntireRow.Copy sht.Range("a" & sht.Range("a65535").End(xlUp).Row + 1)   
        End If
    Next
Next
End Sub

Sub qk()

For i = 2 To Sheets.Count

    Sheets(i).Range("a2:f10000").ClearContents
Next

End Sub

使用筛选拆分工作表

Sub shishi()

Dim i As Integer
'Selection.AutoFilter
For i = 2 To Sheets.Count
	'打开筛选
    Sheet1.Range("A1:F1048").AutoFilter Field:=4, Criteria1:=Sheets(i).Name
    '其中Field:=4表示筛选表格中的第四列,Criteria1表示筛选条件
    '复制粘贴
    Sheet1.Range("a2:g1114").Copy Sheets(i).Range("a2")
    
Next
'selection.AutoFilter
Sheet1.Range("A1:F1048").AutoFilter


End Sub

结果图

在这里插入图片描述

  • 3
    点赞
  • 27
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
以下是一个将多个工作簿合并到一个工作VBA代码: ``` Sub MergeWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long ' Change this to the path\folder location of your files. MyPath = "C:\MyDocuments\" ' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If ' Set the file filter to find Excel files. FilesInPath = "*.xlsx*" ' Set the first result file number to 0. FNum = 0 ' Loop through all files in the folder. If Dir(MyPath & FilesInPath) = "" Then MsgBox "No files found." Exit Sub End If ' Turn off calculation and screen updating. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With ' Set the base worksheet for the merge. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) ' Loop through all files. Do While Dir(MyPath & FilesInPath) <> "" ' Add to the file count. FNum = FNum + 1 ' Re-dimension the array to hold the new file name. ReDim Preserve MyFiles(1 To FNum) ' Store the file name. MyFiles(FNum) = Dir(MyPath & FilesInPath) ' Go to the next file name. DirCount = DirCount + 1 Dir Loop ' Set the starting row for the copy. rnum = 1 ' Loop through all files and worksheets, copying the data to the base worksheet. For FNum = 1 To UBound(MyFiles) Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) For Each sourceSheet In mybook.Worksheets ' Find the last row of data on the source worksheet. SourceRcount = sourceSheet.Cells(Rows.Count, "A").End(xlUp).Row ' Set the source range. Set sourceRange = sourceSheet.Range("A1:Z" & SourceRcount) ' Copy the data to the base worksheet. Set destrange = BaseWks.Range("A" & rnum) sourceRange.Copy destrange ' Increase the row counter. rnum = rnum + SourceRcount Next sourceSheet mybook.Close savechanges:=False Next FNum ' Turn on calculation and screen updating. With Application .Calculation = CalcMode .ScreenUpdating = True End With ' Auto-fit the columns on the base worksheet. BaseWks.Columns.AutoFit End Sub ``` 以下是将工作拆分多个工作簿的VBA代码: ``` Sub SplitWorkbook() Dim FileExtStr As String Dim FileFormatNum As Long Dim xWs As Worksheet Dim xWb As Workbook Dim FolderName As String Dim Lrow As Long Dim OutFolder As String ' Change this to the path\folder location where you want to save the new files. OutFolder = "C:\MyDocuments\" ' Create a new folder for the output files. If Len(Dir(OutFolder, vbDirectory)) = 0 Then MkDir OutFolder End If ' Only save the active sheet. Set xWs = Application.ActiveSheet ' Get the file extension and format number. FileExtStr = ".xlsx" FileFormatNum = 51 ' Find the last row of data on the active sheet. Lrow = xWs.Cells(xWs.Rows.Count, "A").End(xlUp).Row ' Turn off calculation and screen updating. Application.ScreenUpdating = False Application.DisplayAlerts = False ' Loop through each row of data and save each row to a new file. For i = 2 To Lrow ' Create a new workbook. Set xWb = Application.Workbooks.Add ' Save the new workbook to the output folder. FolderName = OutFolder & xWs.Cells(i, "A").Value & FileExtStr ' Save the active sheet to the new workbook in the output folder. xWs.Rows(i).Copy xWb.Worksheets(1).Range("A1").PasteSpecial xlPasteAll ' Save and close the new workbook. xWb.SaveAs FolderName, FileFormatNum xWb.Close False Next i ' Turn on calculation and screen updating. Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub ``` 注意,这些代码应该修改以适应您的具体情况。

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值