VBA 拆分合并工作簿后的表格到新的工作簿中保存到桌面文件夹中

QQ 909478250

于 2024-03-25 15:45:42 发布

阅读量224

点赞数 1

分类专栏： VBA 文章标签： excel

本文链接：https://blog.csdn.net/qq_40178842/article/details/137016472

版权

VBA 专栏收录该内容

6 篇文章 0 订阅

订阅专栏

和上一篇的合并工作簿配合使用

附上源码


Sub 拆分()
    Dim wb As Workbook
    Dim newWb As Workbook
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim cell As Range
    Dim fileName As String
    Dim filePath As String
    Dim folderPatn As String
    Dim arr() As String
      filePath = SelectFile
      
    Set wb = Workbooks.Open(filePath)
    
     folderPatn = CreateFolder
    
    Set ws = wb.Worksheets("Sheet1")
    
       For Each cellA In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row) ' 这里假设要根据A列的值进行拆分
    
             If cellA.Value <> "" Then
           
               fileName = cellA.Value ' 这里假设每个单元格的值作为文件名
           
              Set newWb = Workbooks.Add
              
                      lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
                     For i = 2 To lastRow
                   
                             Dim data As Variant
                             
                             data = ws.Cells(i, "B").Value
                             
                              If data <> "" Then
                      
                                    arr = Split(data, "-")
                              
                                  'workBookName = ws.Range("A" & arr(0))
                                  
                                        If (arr(0) = cellA.Row) Then
                                                                            
                                          'MsgBox data & " ---- " & fileName
        
                                           Set Worksheet = wb.Worksheets(data)
                                                    
                                               'Worksheet.Name = arr(1)
                                                 
                                            Worksheet.Copy after:=newWb.Sheets(newWb.Sheets.Count)
                                            
                                                ' 删除原来的默认工作表（Sheet1）
                                           Application.DisplayAlerts = False ' 关闭删除时的确认提示
                                           newWb.Worksheets("Sheet1").Delete
                                        
                                           Application.DisplayAlerts = True ' 重新开启删除时的确认提示
                                           
                                            Set NewSheet = newWb.Sheets(newWb.Sheets.Count)
                                             NewSheet.Name = arr(1)

                                          End If
                             
                             End If
                             
                       Next i
                       
    
             ' 保存新的工作簿
               newWb.SaveAs folderPatn & "\" & fileName
               newWb.Close

                End If
     
    Next cellA

      


    ' 关闭原始工作簿
    wb.Close
End Sub


Function CreateFolder()
    Dim fso As Object
    Dim desktopPath As String
    Dim newFolder As Object
    Dim folderName As String
   
    ' 创建FileSystemObject对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 获取桌面路径
    desktopPath = Environ("USERPROFILE") & "\Desktop\ NewFolder"
    
       If fso.FolderExists(desktopPath) Then
       
       fso.DeleteFolder desktopPath, True
       
        'MsgBox "文件夹已创建：" & folderPath

    End If

    fso.CreateFolder (desktopPath)
    ' 释放对象
    Set newFolder = Nothing
    Set fso = Nothing
    
    MsgBox "文件夹已成功创建在桌面上。"
    
    CreateFolder = desktopPath
    
End Function