VBA学习(77)：Excel表格拆分通用版终极神器

于 2024-10-07 13:34:35 发布
阅读量383 收藏 4
点赞数 10
分类专栏： VBA学习 文章标签： excel VBA
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/nianfen/article/details/142739215
版权

1.用户窗体-定义变量：

Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim wrdApp As Object
Dim wrdDoc As Object
Dim wrdTable As Object
Dim filePath As String
Dim fileName As String
Dim saveFolder As String
Dim sht As Worksheet
Dim shtName As String
Dim lastRow As Integer, lastCol As Integer
Dim rng As Range
Dim arr(), arrDate(), arrSplit(), tbTitle(), arrNumber(), arrFilter()
Dim SplitCol As Integer
Dim dateCol As Integer, NumberCol As Integer
Dim filterCol As Integer
Dim arrTem()
Dim newRow As Integer
Dim filesCounter As Integer

用户窗体-Sub CkbTitle

Private Sub CkbTitle_Click()
    If Me.CkbTitle Then
        Me.TxbTitle.Visible = True
    Else
        Me.TxbTitle.Visible = False
        Me.TxbTitle = ""
    End If
End Sub

代码解析：插入标题，点击勾选则显示文本框，再点击取消勾选，隐藏文本框。

用户窗体-Sub CmbFilterColumn


Private Sub CmbFilterColumn_Change()
   On Error Resume Next
    Dim dicFilter As Object
    
    Set dicFilter = CreateObject("Scripting.Dictionary")
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbFilterColumn Then
            filterCol = i
            Exit For
        End If
    Next
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbSplitColumn Then
            SplitCol = i
            Exit For
        End If
    Next
    For i = 2 To lastRow
        
        If Me.CmbSplit = "" Then
            dicFilter(arr(i, filterCol)) = 1
        Else
            If arr(i, SplitCol) = Me.CmbSplit Then
                dicFilter(arr(i, filterCol)) = 1
            End If
        End If
    Next
    arrFilter = dicFilter.keys
    Call SortArray(arrFilter)
    Me.CmbInclude.List = arrFilter
    Me.CmbExclude.List = arrFilter
    Me.CmbInclude = ""
    Me.CmbInclude = ""

End Sub

代码解析：其他筛选，改变筛选字段，重新设置其下两个复合框的List

用户窗体-Sub CmbSplit_Change


Private Sub CmbSplit_Change()
    On Error Resume Next
    Dim dicDate As Object
    Dim dicNumber As Object
    Dim dicFilter As Object
    Dim strArr As String, strCmb As String
    Set dicDate = CreateObject("Scripting.Dictionary")
    Set dicNumber = CreateObject("Scripting.Dictionary")
    Set dicFilter = CreateObject("Scripting.Dictionary")
    For i = 2 To lastRow
    strArr = CStr(arr(i, SplitCol))
    strCmb = CStr(Me.CmbSplit)
        
        If dateCol > 0 Then
            If strArr = strCmb Then
                dicDate(arr(i, dateCol)) = 1
            End If
        End If
        
        If NumberCol > 0 Then
            If strArr = strCmb Then
                dicNumber(arr(i, NumberCol)) = 1
            End If
        End If
        
        If filterCol > 0 Then
            If strArr = strCmb Then
                dicFilter(arr(i, filterCol)) = 1
            End If
        End If
        
        
    Next
    Me.CmbMinDate.Clear
    Me.CmbMaxDate.Clear
    arrDate = dicDate.keys
    Call SortArray(arrDate)
    Me.CmbMinDate.List = arrDate
    Me.CmbMaxDate.List = arrDate
    
    Me.CmbMinNumber.Clear
    Me.CmbMaxNumber.Clear
    arrNumber = dicNumber.keys
    Call SortArray(arrNumber)
    Me.CmbMinNumber.List = arrNumber
    Me.CmbMaxNumber.List = arrNumber
    
    Me.CmbInclude.Clear
    Me.CmbExclude.Clear
    arrFilter = dicFilter.keys
    Call SortArray(arrFilter)
    Me.CmbInclude.List = arrFilter
    Me.CmbExclude.List = arrFilter
    
End Sub

代码解析：单选项目change事件，右边的三个筛选都要随之改变。 

用户窗体-Sub CmbSplitColumn_Change

Private Sub CmbSplitColumn_Change()
    'On Error Resume Next
    Dim dicSplit As Object
    Dim dicNumber As Object
    Dim dicDate As Object
    Dim dicFilter As Object
    Set dicSplit = CreateObject("Scripting.Dictionary")
    Set dicDate = CreateObject("Scripting.Dictionary")
    Set dicNumber = CreateObject("Scripting.Dictionary")
    Set dicFilter = CreateObject("Scripting.Dictionary")
    
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbDateColumn Then
            dateCol = i
        ElseIf arr(1, i) = Me.CmbSplitColumn Then
            SplitCol = i
        ElseIf arr(1, i) = Me.CmbNumberColumn Then
            NumberCol = i
        ElseIf arr(1, i) = Me.CmbFilterColumn Then
            filterCol = i
        End If
    Next
    
    For i = 2 To lastRow
        If SplitCol > 0 Then
            dicSplit(arr(i, SplitCol)) = 1
        End If
        If dateCol > 0 Then
            dicDate(arr(i, dateCol)) = 1
        End If
        If NumberCol > 0 Then
            dicNumber(arr(i, NumberCol)) = 1
        End If
        If filterCol > 0 Then
            dicFilter(arr(i, filterCol)) = 1
        End If
    Next
    arrSplit = dicSplit.keys
    Me.CmbSplit.List = dicSplit.keys
    arrDate = dicDate.keys
    Call SortArray(arrDate)
    arrNumber = dicNumber.keys
    Call SortArray(arrNumber)
    arrFilter = dicFilter.keys
    Call SortArray(arrFilter)
    
    Me.CmbMinDate.List = arrDate
    Me.CmbMaxDate.List = arrDate
    
    Me.CmbMinNumber.List = arrNumber
    Me.CmbMaxNumber.List = arrNumber
    
    Me.CmbInclude.List = arrFilter
    Me.CmbExclude.List = arrFilter
    
    
    Me.CmbMinDate = ""
    Me.CmbMaxDate = ""
    Me.CmbMinNumber = ""
    Me.CmbMaxNumber = ""
    
    Me.CmbSplit = ""

End Sub

代码解析：拆分列的change事件，右边的三个筛选都随之改变。

用户窗体-Sub CmbDateColumn_Change

Private Sub CmbDateColumn_Change()
    On Error Resume Next
    Dim dicDate As Object
    Dim arrMinDate(), arrMaxDate()
    
    Set dicDate = CreateObject("Scripting.Dictionary")
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbDateColumn Then
            dateCol = i
            Exit For
        End If
    Next
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbSplitColumn Then
            SplitCol = i
            Exit For
        End If
    Next
    
    
    For i = 2 To lastRow
        
        If Me.CmbSplit = "" Then
            dicDate(arr(i, dateCol)) = 1
        Else
            If arr(i, SplitCol) = Me.CmbSplit Then
                dicDate(arr(i, dateCol)) = 1
            End If
        End If
    Next
    arrDate = dicDate.keys
    Call SortArray(arrDate)
    Me.CmbMinDate.List = arrDate
    Me.CmbMaxDate.List = arrDate
    Me.CmbMinDate = ""
    Me.CmbMaxDate = ""
    
End Sub

代码解析：日期筛选列的change事件，其下两个筛选都随之改变。

用户窗体-Sub CmbNumberColumn_Change


Private Sub CmbNumberColumn_Change()
    On Error Resume Next
    Dim dicNumber As Object
    Dim arrMinNumber(), arrMaxnumber()
    
    Set dicNumber = CreateObject("Scripting.Dictionary")
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbNumberColumn Then
            NumberCol = i
            Exit For
        End If
    Next
    For i = 1 To lastCol
        If arr(1, i) = Me.CmbSplitColumn Then
            SplitCol = i
            Exit For
        End If
    Next
    For i = 2 To lastRow
        
        If Me.CmbSplit = "" Then
            dicNumber(arr(i, NumberCol)) = 1
        Else
            If arr(i, SplitCol) = Me.CmbSplit Then
                dicNumber(arr(i, NumberCol)) = 1
            End If
        End If
    Next
    arrNumber = dicNumber.keys
    Call SortArray(arrNumber)
    Me.CmbMinNumber.List = arrNumber
    Me.CmbMaxNumber.List = arrNumber
    Me.CmbMinNumber = ""
    Me.CmbMaxNumber = ""

End Sub

代码解析：数值筛选列的change事件。

用户窗体-Sub CmbSheets_Change

Private Sub CmbSheets_Change()
    Dim ckBox As Control
    Dim ctrl As Control
    shtName = Me.CmbSheets
    Set xlSheet = xlBook.Sheets(shtName)
    Set rng = xlSheet.UsedRange
    arr = rng.Value
    lastRow = UBound(arr, 1)
    lastCol = UBound(arr, 2)
    
    For i = 1 To lastCol
        ReDim Preserve tbTitle(1 To i)
        tbTitle(i) = arr(1, i)
    Next

    For Each ctrl In Me.Controls
        
        If InStr(ctrl.Name, "CheckBox_") > 0 Then
            Me.Controls.Remove ctrl.Name
        End If
        
    Next
   
    leftPos = Me.LbColumn.Left + 10  ' 左侧位置
    topPos = Me.LbColumn.Top + Me.LbColumn.Height + 2 ' 复选框的顶部位置
    iwidth = 70
    '
    For i = 1 To lastCol
        Set ckBox = Me.Controls.Add("Forms.CheckBox.1", "CheckBox_" & i)
        With ckBox
            .Left = leftPos
            .Top = topPos
            .Width = iwidth
            .Height = 20
            .Caption = tbTitle(i)
            .Value = True
        End With
        '更新位置
        If (i) Mod 4 = 0 Then
            '换行
            leftPos = Me.LbColumn.Left + 10
            topPos = topPos + 20
        Else
            '同行下一个位置
            leftPos = leftPos + iwidth
        End If
    Next
    
    Me.CmbSplitColumn.Clear
    Me.CmbDateColumn.Clear
    Me.CmbNumberColumn.Clear
    Me.CmbFilterColumn.Clear

    For i = 1 To lastCol
        
        If IsDate(arr(2, i)) Then   '日期字段
            Me.CmbDateColumn.AddItem arr(1, i)
        ElseIf IsNumeric(arr(2, i)) Then      '数值字段
            Me.CmbNumberColumn.AddItem arr(1, i)
        Else      '除日期、数值字段，其他可供筛选字段
            Me.CmbFilterColumn.AddItem (arr(1, i))
        End If
    Next
    Me.CmdSelect.Visible = True
    Me.CmbDateColumn = ""
    Me.CmbMinDate.Clear
    Me.CmbMaxDate.Clear
    
    Me.CmbNumberColumn = ""
    Me.CmbMinNumber.Clear
    Me.CmbMaxNumber.Clear
    
    Me.CmbFilterColumn = ""
    Me.CmbInclude.Clear
    Me.CmbExclude.Clear
    
    
    Me.CmbSplit.Clear
    dateCol = 0
    SplitCol = 0
    With Me.CmbSplitColumn
        .Clear
        .List = tbTitle
        .Text = .List(0)
    End With
    
End Sub

代码解析：拆分目标工作表的change事件，窗体上的大部筛选都要重设。

用户窗体-Sub CmdChooseFile_Click

Private Sub CmdChooseFile_Click()
    Set xlApp = CreateObject("Excel.Application")
    Me.TxbExcelFile = FileSelected
    filePath = Me.TxbExcelFile
    If Not filePath = "" Then
        Set xlBook = xlApp.Workbooks.Open(filePath)
    Else
        MsgBox "请选择文件！"
        Exit Sub
    End If
    For Each sht In xlBook.Worksheets
        If sht.Cells(1, 1) <> "" Then
            Me.CmbSheets.AddItem sht.Name
        End If
    Next
    
    Me.CmbSheets.Text = Me.CmbSheets.List(0)
    shtName = Me.CmbSheets

End Sub

代码解析：选择拆分文件。

用户窗体-Sub CmdChoosePath_Click

Private Sub CmdChoosePath_Click()
    Dim preFolder As String
    preFolder = Me.TxbWordPath
    If Not IsFolderExists(preFolder) Then
        preFolder = ThisWorkbook.Path
    End If
    saveFolder = PathSelected
    If Not saveFolder = "" Then
        Me.TxbWordPath = saveFolder
    Else
        saveFolder = preFolder
        Me.TxbWordPath = saveFolder
    End If
End Sub

代码解析：选择保存路径。

用户窗体-Sub CmbDateColumn_Change

Private Sub CmdOutPut_Click()
    On Error Resume Next
    Dim arrTitle()
    Dim minDate As Date, maxDate As Date
    Dim minNumber As Double, maxNumber As Double
    Dim strInclude As String, strExclude As String
    Application.ScreenUpdating = False
    filesCounter = 0
    t = 0
    For i = LBound(tbTitle) To UBound(tbTitle)
        If Me.Controls("CheckBox_" & i) = True Then
            t = 1
            Exit For
        End If
    Next
    
    If t = 0 Then
        MsgBox "至少选择一列"
        Exit Sub
    End If
    If Me.OptWord Then
    Set wrdApp = CreateObject("Word.Application")
    End If
'    wrdApp.Visible = True ' 将Word应用程序设置为可见
    For i = 1 To lastCol
        If Controls("CheckBox_" & i) Then
            ReDim Preserve arrTitle(k)
            arrTitle(k) = Controls("CheckBox_" & i).Caption
            k = k + 1
        End If
    Next
    newRow = UBound(arrTitle, 1)
    ReDim arrTem(0 To newRow, 0 To 0)
    For i = 0 To newRow
        arrTem(i, 0) = arrTitle(i)
    Next

    '日期范围
    If Me.CmbDateColumn <> "" Then
        If Me.CmbMinDate = "" Then
            minDate = arrDate(LBound(arrDate))
        Else
            minDate = CDate(Me.CmbMinDate)
        End If
        
        
        If Me.CmbMaxDate = "" Then
            maxDate = arrDate(UBound(arrDate))
            
        Else
            maxDate = CDate(Me.CmbMaxDate)
        End If
    End If
    
    '金额范围
    If Me.CmbNumberColumn <> "" Then
        If Me.CmbMinNumber = "" Then
            minNumber = CDbl(arrNumber(LBound(arrNumber)))
        Else
            minNumber = CDbl(Me.CmbMinNumber)
        End If
        
        If Me.CmbMaxNumber = "" Then
            maxNumber = CDbl(arrNumber(UBound(arrNumber)))
            
        Else
            maxNumber = CDbl(Me.CmbMaxNumber)
        End If
    End If
    '筛选字段
    If Me.CmbFilterColumn <> "" Then
        If Me.CmbInclude = "" Then
            strInclude = ""
        Else
            strInclude = CStr(Me.CmbInclude)
        End If
        
        If Me.CmbExclude = "" Then
            strExclude = "1234567890qwertyuiop"
        Else
            strExclude = CStr(Me.CmbExclude)
        End If
    End If
    
    If Me.CmbSplitColumn = "" Then    '客户为空
        MsgBox "拆分字段不能为空"
        Exit Sub
    End If
    
    If Me.CmbSplit = "" Then '未选具体拆分项目     第一层IF
        If Me.CmbDateColumn = "" Then      '未选日期列    第二层IF
            If Me.CmbNumberColumn = "" Then    '未选数值列   第三层IF
                If Me.CmbFilterColumn = "" Then '未选筛选列    第四层IF
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) Then
                                m = UBound(arrTem, 2) + 1
                                ReDim Preserve arrTem(0 To newRow, 0 To m)
                                For k = 0 To newRow
                                    For n = 1 To lastCol
                                        If arr(1, n) = arrTem(k, 0) Then
                                            arrTem(k, m) = arr(j, n)
                                            
                                        End If
                                        
                                    Next
                                    
                                Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
'                     Stop
                    Next
                Else  '选了筛选列   e1   第四层IF else
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And InStr(arr(j, filterCol), strInclude) > 0 _
                                And InStr(arr(j, filterCol), strExclude) = 0 Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                    
                End If    '第四层IF  end
            Else    '选了数值列  第三层IF else
                If Me.CmbFilterColumn = "" Then '未选筛选列
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And CDbl(arr(j, NumberCol)) >= minNumber _
                                And CDbl(arr(j, NumberCol)) <= maxNumber Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                Else  '选了筛选列 E3
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And CDbl(arr(j, NumberCol)) >= minNumber _
                                And CDbl(arr(j, NumberCol)) <= maxNumber _
                                And InStr(arr(j, filterCol), strInclude) > 0 _
                                And InStr(arr(j, filterCol), strExclude) = 0 Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                    
                End If
                
            End If   '第三层IF end
            
        Else    '第二层IF else  选择了日期列
            If Me.CmbNumberColumn = "" Then    '选择了日期列，未选数值列
                If Me.CmbFilterColumn = "" Then '选择了日期列，未选数值列,未选筛选列
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _
                                And CDate(arr(j, dateCol)) <= maxDate Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                Else  ' '选择了日期列，未选数值列,选了筛选列
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _
                                And CDate(arr(j, dateCol)) <= maxDate _
                                And InStr(arr(j, filterCol), strInclude) > 0 _
                                And InStr(arr(j, filterCol), strExclude) = 0 Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                    
                End If
            Else     '选择了日期列，选了数值列
                If Me.CmbFilterColumn = "" Then  '选择了日期列，选了数值列,未选筛选列
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _
                                And CDate(arr(j, dateCol)) <= maxDate _
                                And CDbl(arr(j, NumberCol)) >= minNumber _
                                And CDbl(arr(j, NumberCol)) <= maxNumber Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                Else  '选择了日期列，选了数值列,选了筛选列
                    For i = LBound(arrSplit) To UBound(arrSplit)
                        For j = 2 To lastRow
                            If arr(j, SplitCol) = arrSplit(i) And CDate(arr(j, dateCol)) >= minDate _
                                And CDate(arr(j, dateCol)) <= maxDate _
                                And CDbl(arr(j, NumberCol)) >= minNumber _
                                And CDbl(arr(j, NumberCol)) <= maxNumber _
                                And InStr(arr(j, filterCol), strInclude) > 0 _
                                And InStr(arr(j, filterCol), strExclude) = 0 Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                    End If
                                Next
                            Next
                            End If
                        Next
                        fileName = arrSplit(i) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                        fileName = Replace(fileName, "\", "_")
                        fileName = Replace(fileName, "/", "_")
                        Call SaveToFile
                        ReDim Preserve arrTem(0 To newRow, 0 To 0)
                        
                    Next
                    
                End If
                
            End If
            
            
        End If
    Else    '选择了具体拆分项目
        If Me.CmbDateColumn = "" Then      '未选日期列    第二层IF
            If Me.CmbNumberColumn = "" Then    '未选数值列   第三层IF
                If Me.CmbFilterColumn = "" Then '未选筛选列    第四层IF
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit Then
                            m = UBound(arrTem, 2) + 1
                            ReDim Preserve arrTem(0 To newRow, 0 To m)
                            For k = 0 To newRow
                                For n = 1 To lastCol
                                    If arr(1, n) = arrTem(k, 0) Then
                                        arrTem(k, m) = arr(j, n)
                                        
                                    End If
                                    
                                Next
                                
                            Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                Else  '选了筛选列   e1   第四层IF else
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And InStr(arr(j, filterCol), strInclude) > 0 _
                            And InStr(arr(j, filterCol), strExclude) = 0 Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                    
                                End If
                                
                            Next
                            
                        Next
                        End If
                        
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                End If    '第四层IF  end
            Else    '选了数值列  第三层IF else
                If Me.CmbFilterColumn = "" Then '未选筛选列
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And CDbl(arr(j, NumberCol)) >= minNumber _
                            And CDbl(arr(j, NumberCol)) <= maxNumber Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                    
                                End If
                                
                            Next
                            
                        Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                Else  '选了筛选列 E3
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And CDbl(arr(j, NumberCol)) >= minNumber _
                            And CDbl(arr(j, NumberCol)) <= maxNumber _
                            And InStr(arr(j, filterCol), strInclude) > 0 _
                            And InStr(arr(j, filterCol), strExclude) = 0 Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                    
                                End If
                                
                            Next
                            
                        Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                    
                End If
                
            End If   '第三层IF end
            
        Else    '第二层IF else  选择了日期列
            If Me.CmbNumberColumn = "" Then    '选择了日期列，未选数值列
                If Me.CmbFilterColumn = "" Then '选择了日期列，未选数值列,未选筛选列
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _
                            And CDate(arr(j, dateCol)) <= maxDate Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                    
                                End If
                                
                            Next
                            
                        Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                Else  ' '选择了日期列，未选数值列,选了筛选列
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _
                            And CDate(arr(j, dateCol)) <= maxDate _
                            And InStr(arr(j, filterCol), strInclude) > 0 _
                            And InStr(arr(j, filterCol), strExclude) = 0 Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                    
                                End If
                                
                            Next
                            
                        Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                End If
            Else     '选择了日期列，选了数值列
                If Me.CmbFilterColumn = "" Then  '选择了日期列，选了数值列,未选筛选列
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _
                            And CDate(arr(j, dateCol)) <= maxDate _
                            And CDbl(arr(j, NumberCol)) >= minNumber _
                            And CDbl(arr(j, NumberCol)) <= maxNumber Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                    
                                End If
                                
                            Next
                            
                        Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                Else  '选择了日期列，选了数值列,选了筛选列
                    
                    For j = 2 To lastRow
                        If arr(j, SplitCol) = Me.CmbSplit And CDate(arr(j, dateCol)) >= minDate _
                            And CDate(arr(j, dateCol)) <= maxDate _
                            And CDbl(arr(j, NumberCol)) >= minNumber _
                            And CDbl(arr(j, NumberCol)) <= maxNumber _
                            And InStr(arr(j, filterCol), strInclude) > 0 _
                            And InStr(arr(j, filterCol), strExclude) = 0 Then
                        m = UBound(arrTem, 2) + 1
                        ReDim Preserve arrTem(0 To newRow, 0 To m)
                        For k = 0 To newRow
                            For n = 1 To lastCol
                                If arr(1, n) = arrTem(k, 0) Then
                                    arrTem(k, m) = arr(j, n)
                                End If
                            Next
                        Next
                        End If
                    Next
                    fileName = Me.CmbSplit & "_" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
                    fileName = Replace(fileName, "\", "_")
                    fileName = Replace(fileName, "/", "_")
                    Call SaveToFile
                    ReDim Preserve arrTem(0 To newRow, 0 To 0)
                    
                    
                    
                End If
                
            End If
            
            
        End If
        
        
    End If
    
   MsgBox "成功拆分【" & filesCounter & "】个文件"
    '打开拆分文件所在目录
    Shell "explorer.exe " & saveFolder, vbMaximizedFocus
    
     On Error Resume Next
    If Not xlBook Is Nothing Then
        '工作簿已打开，执行关闭
        xlBook.Close False
    End If
    wrdApp.Quit
    xlApp.Quit
    Set wrdTable = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
   Unload Me
         Application.ScreenUpdating = True
End Sub

代码解析：导出文件

1、如果没有选择“单选项目”，则会将拆分列的所有项目拆分为单独文件。

2、循环拆分项目，根据右边筛选条件，提取数据，存到数据，导出到文件。

3、代码量主要在选择判断方面。

用户窗体-其他代码


Private Sub CmdSelect_Click()
    If Me.CmdSelect.Caption = "全选" Then
        For i = LBound(tbTitle) To UBound(tbTitle)
            Me.Controls("CheckBox_" & i) = True
        Next
        Me.CmdSelect.Caption = "全消"
        Me.CmdSelect.BackColor = &HC0FFC0
    Else
        For i = LBound(tbTitle) To UBound(tbTitle)
            Me.Controls("CheckBox_" & i) = False
        Next
        Me.CmdSelect.Caption = "全选"
        Me.CmdSelect.BackColor = &H8080FF
    End If
End Sub

Private Sub OptExcel_Change()
    If OptExcel Then
        Me.OptExcel.ForeColor = vbRed
        Me.OptWord.ForeColor = vbBlue
    Else
        Me.OptExcel.ForeColor = vbBlue
        Me.OptWord.ForeColor = vbRed
    End If
End Sub

Private Sub UserForm_Initialize()
    saveFolder = ThisWorkbook.Path
    Me.TxbWordPath = saveFolder
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    On Error Resume Next
    If Not xlBook Is Nothing Then
        '工作簿已打开，执行关闭
        xlBook.Close False
    End If
    wrdApp.Quit
    xlApp.Quit
    Set wrdTable = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
  
End Sub

Sub SaveToFile()
    '如果没有明细数据，导出选项
    If UBound(arrTem, 2) = LBound(arrTem, 2) Then
        If Not Me.CheckBox1 Then
            Exit Sub
        End If
    End If
    filesCounter = filesCounter + 1
    If Me.OptExcel Then
        Call SaveToExcel
    Else
        Call SaveToWord
    End If
End Sub
Sub SaveToWord()
   
    'Stop
    '创建新的Word文档
    Set wrdDoc = wrdApp.Documents.Add
    Set myrange = wrdDoc.Range(0, 0)
    With myrange
        .InsertBefore Me.TxbTitle & vbCrLf
        With .Font
            .Name = "黑体"
            .Size = 16
            '.Bold = True
        End With
        '.ParagraphFormat.Alignment = wdAlignParagraphCenter
        '.InsertParagraphAfter
        .Collapse Direction:=wdCollapseEnd
    End With
    With wrdDoc.Paragraphs(1)
        .Alignment = wdAlignParagraphCenter
    End With
    
    '添加新的表格
    Set wrdTable = wrdDoc.Tables.Add(myrange, UBound(arrTem, 2) + 1, newRow + 1)
    '设置表格边框格式为灰色虚线
    With wrdTable
        .Style = "网格型"
    End With
    For c = 1 To UBound(arrTem, 2) + 1
        For d = 1 To newRow + 1
            wrdTable.Cell(c, d).Range.Text = arrTem(d - 1, c - 1)
        Next
    Next
    wrdDoc.SaveAs saveFolder & "\" & fileName
    wrdDoc.Close SaveChanges:=False
End Sub


Sub SaveToExcel()
    '原来导出的是word文件，扩展名改一下
    fileName = Replace(fileName, ".docx", ".xlsx")
    Workbooks.Add
    With ActiveWorkbook
        If Me.CkbTitle Then
            
            .Sheets(1).Range(Cells(1, 1), Cells(1, UBound(arrTem, 1) + 1)).MergeCells = True
            .Sheets(1).Range("A1") = Me.TxbTitle
            .Sheets(1).Range("A1").HorizontalAlignment = xlCenter
            .Sheets(1).Range("A2").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1) = Application.WorksheetFunction.Transpose(arrTem)
        Else
            
            .Sheets(1).Range("A1").Resize(UBound(arrTem, 2) + 1, UBound(arrTem, 1) + 1) = Application.WorksheetFunction.Transpose(arrTem)
            
        End If
        .SaveAs fileName:=saveFolder & "\" & fileName
        .Close
    End With
End Sub

xwLink1996
关注
专栏目录
VBA------------实例(表格数据拆分)
YANG_1605的博客
12-25 1430
通过对VBA的学习，已经基本可以通过代码来操作表格进行数据处理，本次就通过实际编写代码来进行描述： 首先，先创建一张表格，用来保存最初始的数据。 本次主要实现的功能是：通过所属部门的名称对人员进行分类，并按照部门名称将表格拆分成多个子表。 代码实现过程如下： Sub 拆分工作表() Application.DisplayAlerts = False '不显示错误提示窗 Application.ScreenUpdating = False '不闪屏 D.
VBA 拆分Excel为多个文件
sirius6的专栏
07-07 1086
拆分之前数据： 按照B列类型拆分为多个文件，相同前缀的放到同一个Excel中，并且按照类型不同分成多个页存放。 拆分后文件： VBA代码： Sub SplitSheetDataBaseOnCloum() Dim objWorksheet As Excel.Worksheet Dim nLastRow, nRow, nNextRow As Integer Dim strColumnValue As String Dim objDictionary As O...
钢结构设计用：EXCEL表格自定义函数
09-01
用VBA自编的一个用EXCEL表格做钢结构计算用的自定义函数，提高表格编制效率。 1）其中包括 7 个函数：★Gins--型钢截面参数。★GWp--型钢塑性截面参数，★GStr--钢材强度查表，★HStr--焊缝强度查表，★LStr--螺栓强度查表，☆CStr--混凝土强度查表，☆SStr--钢筋强度查表。 2）表格开启运行 “宏” 功能。 3）其中：提供.bas文件，VBA编写源代码。 4）在WPS表格中使用时，请安装VBA插件。
【Office】【VBA宏】使用宏实现表格中sheet表拆分成独立的文件
qq_42285057的博客
04-26 2137
将单个的sheet表拆分成独立文件。
VBA代码拆分excel
遨游大海
08-12 2111
忙活两小时，终于帮老姐实现了拆分工作excel的需求，记录下，说不定以后可以用到。。 需求：一个excel文件工作簿可能包含多个工作表(比如sheetA，sheetB,sheetC),每个sheet里每一行都有一个地市字段，现需要根据地市拆分成不同的excel（每个excel包含sheetA，sheetB,sheetC，而且每个sheet里的记录都是同一个地市的）。    代码如下：  S
编写VBA程序，实现拆分表格
weixin_42593701的博客
02-18 425
答复：我可以帮助你编写VBA程序，实现拆分表格。首先，可以使用VBA的Range对象，指定要拆分的单元格区域，然后使用For-Next循环迭代每一行，根据不同的条件来拆分表格。此外，还可以使用VBA的列表框(ListBox)，实现拆分表格的可视化效果。 ...
VBA代码实现CAD假表格转excel表格
06-11
通过VBA代码高效实现CAD线段构成的表格转换到EXCEL，主要方法是用IntersectWith函数获取所有线段的交点，并对交点的X,Y坐标排序，建立EXCEL输出表格行列关系，然后通过文字与X,Y坐标的关系，确定文字所在行列位置。
VBA实现Excel表格根据列拆分工作簿，再由工作簿根据列拆分成工作表.txt
11-30
VBA（Visual Basic for Applications）是Excel内置的一种编程语言，它允许我们创建自定义宏和功能，以自动化复杂的任务，如拆分工作簿和工作表。针对给定的标题和描述，我们将探讨如何使用VBA来实现按列拆分工作簿，...
Excel VBA 操作 拆分当前Excel表中 / 所选取文件夹所有子文件中 所有sheet保存到对应文件夹路径中拆分表内
06-05
在Excel VBA编程中，有时候我们需要对大型工作簿进行管理和优化，这可能涉及到将一个大文件拆分成多个小文件，每个文件对应原工作簿中的一个单独工作表。这个任务可以通过编写VBA宏来实现，从而自动化整个过程。下面...
VBA+ADO 连接Excel表格查询操作数据(SQL语句操作)
06-18
VBA+ADO 连接Excel表格查询操作数据(SQL语句操作) SQL语句操作表格
VBA宏脚本自动拆分EXCEL表
03-31
按指定的列和行，拆分表。 例如：一个综合性的excel报表，第1行C列是省份，而且此综合性报表有多个sheet要拆分，想要实现拆分所有sheet，并按省份合并成一个excel表，比如所有辽宁省的数据合并成一个excel文件以不同的sheet体现。用此脚本即可实现。 关键点： 1、标题行唯一，不能跨行； 2、以某列为的数据为标准值进行拆分，该列不能有合并单元格； 3、每个sheet单独执行脚本拆分； 4、最后多个sheet是否能够按拆分数据标准合并成一个excel文件，主要看每次拆分时的给新文件起的名称是否一致，文件存在则新增sheet，不存在则创建文件。 另有附带小工具函数： 获取数量列号的英文字母、判断字符是否是英文、替换非汉字\数字\字母的字符、判断文件是否存在。
VBA 合并与拆分 Excel 文件
09-21
使用 VBA 宏实现文件的合并与拆分 合并后的文件会自动存放在该文件的 MergeFiles 工作表中； 如果要拆分文件，需要将要拆分的内容放到 SplitFiles 工作表中。该宏自动会将第一列中值相同的行拆分到一个文件中，同时以该值作为文件名
VBA的Excel文件读写操作.zip
06-24
将TXT文档的数据按照一定的格式写入Excel,并跟据日期或者特定条件可以查询数据，并自动绘制曲线图！不含任何空间，纯代代码，方便移植。
VBA 拆分Excel中的各sheet为文件
菜鸟记录
04-29 776
⏹VBA 拆分Excel中的各sheet为文件
Excel·VBA按列拆分工作表、工作簿
热门推荐
hhhhh_51的博客
01-10 1万+
1，工作表按列拆分为工作表；2，工作表按列拆分为工作簿；3，工作簿按列拆分；4，工作表按列拆分，支持多列关键值；5，工作表按列拆分，先拆分为工作簿再拆分为工作表
VBA之灵活的拆分表
amamiyayouko的博客
03-26 1507
有这样的需求,想把工作表中的D列,按照筛选部门拆分成一个个独立的工作表,新的工作表名就是部门的名字 Sub chaifenshuju() Dim sht As Worksheet Dim k, i, j As Integer Dim irow As Integer '这个说的是一共多少行 irow = Sheet1.Range(“a65536”).End(xlUp).Row '拆分表 For i...
VBA excel 表格将多行拆分成多个表格或 文件 或者合并 多个表格
最新发布
estrusKing的博客
06-05 1572
为了将Excel中的数万行数据拆分成多个个每个固定行数的独立工作表，并且保留每个工作表的表头，你可以使用以下VBA脚本。这个脚本会复制表头到每个新的工作表，并将后续的数据行按固定行行的间隔进行拆分打开Excel并按下Alt + F11打开VBA编辑器。在VBA编辑器中，右键点击你的工作簿名称，然后选择插入 -> 模块，以创建一个新的模块。在新模块的代码窗口中，复制并粘贴以下VBA代码：确保你的数据在Sheet1上（或者将代码中的"Sheet1"替换为你的实际工作表名称）。
Excel·VBA按行拆分工作表
hhhhh_51的博客
02-28 7973
按照固定行数拆分工作表：1，工作表按行拆分为工作表；2，工作表按行拆分为工作薄；3，工作表按行拆分
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

xwLink1996

你的鼓励将是我创作的最大动力

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付：¥1
获取中
扫码支付

您的余额不足，请更换扫码支付或充值

打赏作者

实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

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

余额充值