内容提要
1、在工作表Sheet1里,命令按钮点击事件,显示用户窗体:
Private Sub CmdSplit_Click() UserForm1.ShowEnd Sub
2、在myModule里,fileSelected、FolderSelected、Pxy自定义函数:
3、在用户窗体UserForm1里,拆分工作表相关代码:
Dim FSO As Object, DataFile As String, SaveFolder As String, dic As Object
Dim 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 = SaveFolder
End 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 With
End 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
' Stop
End Sub
Private Sub CmdChooseFolder_Click()
Dim preFolder As String
preFolder = Me.TxbSaveFolder
SaveFolder = FolderSelected
If SaveFolder = "" Then
SaveFolder = preFolder
Else
Me.TxbSaveFolder = SaveFolder
End If
End 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 If
End 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 Me
End Sub
Private Sub Cmd_Exit_Click()
If Not wbSource Is Nothing Then
wbSource.Close savechanges:=False
End If
Unload Me
End Sub
联系客服