|
楼主,我把你的代码改了下,这样不依赖窗体了,采用对话框输入所要的值就行:
- Sub TEST()
- 'Private Sub CommandButton1_Click() '可绑定在命令按钮上
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Dim arr As Variant
- Dim i, s As Integer
- Dim brr()
- Dim wb, wb1 As Workbook
- Dim d As Object
- Dim hlrow As Integer, cutcolumn As Integer, cuttype As Integer
- Set d = CreateObject("scripting.dictionary")
- Dim sh As Worksheet
- hlrow = InputBox("请输入标题行数:", "拆分表格", "1")
- cutcolumn = InputBox("请输入拆分列(第一列是1,第二列是2,以此类推):", "拆分表格", "1")
- cuttype = InputBox("请选择拆分类型(拆分到本工作簿是1,拆分为多个独立工作簿是2,拆分为一个工作簿是3):", "拆分表格", "1")
- If cuttype = 1 Then
- For Each sh In Worksheets
- If sh.Name <> ActiveSheet.Name Then sh.Delete
- Next sh
- End If
- arr = ActiveSheet.Range("a1").CurrentRegion
- For i = hlrow + 1 To UBound(arr)
- If Not d.exists(arr(i, cutcolumn)) Then
- Set d(arr(i, cutcolumn)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
- Else
- Set d(arr(i, cutcolumn)) = Union(d(arr(i, cutcolumn)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
- End If
- Next i
- If cuttype = 3 Then
- Application.SheetsInNewWorkbook = d.Count
- Set wb1 = Workbooks.Add
- i = 1
- For Each k In d.keys
- wb1.Worksheets(i).Name = k
- i = i + 1
- Next k
- End If
- x = d.keys
- For k = 0 To UBound(x)
- If cuttype = 1 Then
- Worksheets.Add after:=Worksheets(Worksheets.Count)
- ActiveSheet.Name = x(k)
- ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy ActiveSheet.[a1]
- d.items()(k).Copy ActiveSheet.Cells(hlrow + 1, 1)
- For i = 1 To UBound(arr, 2)
- For Each sh In ThisWorkbook.Worksheets
- If sh.Name <> x(k) Then
- Sheets(x(k)).Columns(i).ColumnWidth = sh.Columns(i).ColumnWidth
- End If
- Next sh
- Next i
- End If
- If cuttype = 2 Then
- Application.SheetsInNewWorkbook = 1
- Set wb = Workbooks.Add
- With wb.Worksheets(1)
- ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy .[a1]
- d.items()(k).Copy .Cells(hlrow + 1, 1)
- For i = 1 To UBound(arr, 2)
- .Columns(i).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(i).ColumnWidth
- Next i
- wb.SaveAs Filename:=ThisWorkbook.Path & "" & x(k) & ".xls"
- wb.Close
- End With
- End If
- If cuttype = 3 Then
- ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy wb1.Worksheets(x(k)).[a1]
- d.items()(k).Copy wb1.Worksheets(x(k)).Cells(hlrow + 1, 1)
- For i = 1 To UBound(arr, 2)
- wb1.Sheets(x(k)).Columns(i).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(i).ColumnWidth
- Next i
- End If
- Next k
- If cuttype = 3 Then
- wb1.SaveAs Filename:=ThisWorkbook.Path & "" & "拆分数据表.xls"
- wb1.Close False
- End If
- End
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码
|
评分
-
2
查看全部评分
-
|