|
1、在工作表Sheet1里，命令按钮点击事件，显示用户窗体： Private Sub CmdSplit_Click() UserForm1.ShowEnd Sub 2、在myModule里，fileSelected、FolderSelected、Pxy自定义函数： Function fileSelected() With Application.FileDialog(msoFileDialogFilePicker) If .Show = -1 Then fileSelected = .SelectedItems(1) Else Exit Function End If End WithEnd Function
Function FolderSelected(Optional title As String = "请选择文件夹......") With Application.FileDialog(msoFileDialogFolderPicker) .title = title .InitialFileName = ThisWorkbook.Path If .Show = -1 Then FolderSelected = .SelectedItems(1) Else Exit Function End If End WithEnd Function
Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0) '********************************** '//参数说明： '//arr(),数组，可以是一维也可以是二维 '//FieldName，字段名，需要定位的字段名 '//arrType=0,表示一维数组 '//arrType=1,表示二维数组，查找第一列 '//arrType=2,表示二维数组，查找第一行 '********************************** k = 0: t = 0 Select Case arrType Case Is = 0 For i = LBound(arr) To UBound(arr) k = k + 1 If arr(i) = FieldName Then t = 1 Exit For End If Next Case Is = 1 For i = LBound(arr, 1) To UBound(arr, 1) k = k + 1 If arr(i, 1) = FieldName Then t = 1 Exit For End If Next Case Is = 2 For i = LBound(arr, 2) To UBound(arr, 2) k = k + 1 If arr(1, i) = FieldName Then t = 1 Exit For End If Next End Select If t = 1 Then Pxy = k Else Pxy = 0 End IfEnd Function
3、在用户窗体UserForm1里，拆分工作表相关代码： Dim FSO As Object, DataFile As String, SaveFolder As String, dic As ObjectDim wbSource As Workbook
Private Sub UserForm_Initialize() Set FSO = CreateObject("Scripting.FileSystemObject") DataFile = ThisWorkbook.Path & "\源数据.xlsx" If Not FSO.fileexists(DataFile) Then DataFile = "" End If Me.TxbDataFile = DataFile SaveFolder = ThisWorkbook.Path & "\分表" If Not FSO.FolderExists(SaveFolder) Then SaveFolder = "" End If Me.TxbSaveFolder = SaveFolderEnd Sub
Private Sub TxbDataFile_Change() Dim ws As Worksheet If Not FSO.fileexists(Me.TxbDataFile) Then Exit Sub Set wbSource = Workbooks.Open(Me.TxbDataFile) wbSource.Windows(1).Visible = False Me.CmbDataSheet.Clear For Each ws In wbSource.Sheets If ws.UsedRange.Rows.Count > 2 Then Me.CmbDataSheet.AddItem ws.Name End If Next With Me.CmbDataSheet .Text = .List(0) End WithEnd Sub
Private Sub CmbDataSheet_Change() On Error Resume Next Dim arr(), iRow As Integer, iCol As Integer, temp() Dim whCode As String '//仓库编码 Dim whName As String '//仓库名称 Dim manager As String '//负责人 If Me.CmbDataSheet = "" Then Exit Sub Set ws = wbSource.Sheets(Me.CmbDataSheet.Text) Set dic = CreateObject("Scripting.Dictionary") With ws lastRow = .Cells.Find(what:="*", _ lookat:=xlPart, _ LookIn:=xlFormulas, _ searchorder:=xlByRows, _ searchdirection:=xlPrevious).Row lastCol = .UsedRange.Columns.Count arr = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Value End With iRow = UBound(arr) iCol = UBound(arr, 2) For i = 2 To iRow whCode = arr(i, Pxy(arr, "仓库编码", 2)) whName = arr(i, Pxy(arr, "仓库名称", 2)) manager = arr(i, Pxy(arr, "负责人", 2)) If arr(i, 1) <> "" Then dkey = whCode & "-" & whName & "-" & manager If Not dic.exists(dkey) Then k = 2 ReDim temp(1 To iCol - 3, 1 To k) m = 0 For j = 1 To iCol If InStr("/仓库编码/仓库名称/负责人/", "/" & arr(1, j) & "/") = 0 Then m = m + 1 temp(m, 1) = arr(1, j) temp(m, k) = arr(i, j) End If Next Else temp = dic(dkey) k = UBound(temp, 2) + 1 ReDim Preserve temp(1 To iCol - 3, 1 To k) m = 0 For j = 1 To iCol If InStr("/仓库编码/仓库名称/负责人/", "/" & arr(1, j) & "/") = 0 Then m = m + 1 temp(m, k) = arr(i, j) End If Next End If dic(dkey) = temp End If Next' StopEnd Sub
Private Sub CmdChooseFolder_Click() Dim preFolder As String preFolder = Me.TxbSaveFolder SaveFolder = FolderSelected If SaveFolder = "" Then SaveFolder = preFolder Else Me.TxbSaveFolder = SaveFolder End IfEnd Sub
Private Sub CmdSelectDataFile_Click() Dim preDataFile preDataFile = Me.TxbDataFile DataFile = fileSelected If DataFile = "" Then DataFile = preDataFile Else If Not wbSource Is Nothing Then wbSource.Close savechanges:=False Set wbSource = Nothing End If Me.TxbDataFile = DataFile End IfEnd Sub
Private Sub CmdSplit_Click() Dim wb As Workbook, ws As Worksheet Dim temp(), rng As Range If Me.TxbDataFile = "" Then MsgBox "源数据文件为空，请选择文件！" Exit Sub End If If Me.CmbDataSheet = "" Then MsgBox "工作表为空，请选择！" Exit Sub End If If Me.TxbSaveFolder = "" Then MsgBox "保存文件夹为空，请选择！" Exit Sub End If For Each Key In dic.keys temp = dic(Key) Set wb = Workbooks.Add Set ws = wb.Sheets(1) With ws .Name = Key Set rng = .Cells(1, 1).Resize(UBound(temp, 2), UBound(temp)) With rng .NumberFormat = "@" .Value2 = Application.WorksheetFunction.Transpose(temp) For i = 1 To .Columns.Count If .Cells(1, i) = "数量" Then .Columns(i).NumberFormat = "0" End If Next .Columns.AutoFit '.Borders.LineStyle = 1 End With End With Application.DisplayAlerts = False wb.SaveAs SaveFolder & "\" & Key & ".xlsx" Application.DisplayAlerts = True wb.Close Next MsgBox "Done!" If Not wbSource Is Nothing Then wbSource.Close savechanges:=False End If Unload MeEnd Sub
Private Sub Cmd_Exit_Click() If Not wbSource Is Nothing Then wbSource.Close savechanges:=False End If Unload MeEnd Sub
|
