[已解决]复制标题栏的求助

安全网 · 发表于 2014-12-18 10:38

Private Sub CommandButton1_Click()
Dim arr, d, mkey, i, noC
Dim wk As Workbook
Dim fso, mf

On Error Resume Next
Set Rng = Sheet1.UsedRange
1000:
icol = Application.InputBox("请输入需要拆分的列号：", , "请输入A, B, C……", , , , 2)
If icol = "请输入A, B, C……" Then
MsgBox "没有输入拆分列号！": GoTo 1000
ElseIf icol = False Then
Exit Sub

ElseIf Cells(1, icol).Column > Rng.End(xlToRight).Column Then
MsgBox "输入的列号无效或已超过有效范围！": GoTo 1000
End If
Set fso = CreateObject("scripting.filesystemobject")
With fso
      mf = ThisWorkbook.Path & "\按" & Range(icol & "2") & "拆分"
      If .folderexists(mf) Then .deletefolder (mf)
      .createfolder (mf)
End With
Set fso = Nothing
Application.ScreenUpdating = False
arr = Intersect(Columns(icol), Sheet1.UsedRange)
Set d = CreateObject("scripting.dictionary")
Cells.AutoFilter
For i = 3 To UBound(arr, 1)
      If arr(i, 1) <> "" Then
         If Not d.exists(arr(i, 1)) Then
            Set wk = Workbooks.Add
            d(arr(i, 1)) = ""
            Cells.AutoFilter Field:=Columns(icol).Column, Criteria1:=arr(i, 1)
            Range("A:A").SpecialCells(xlCellTypeVisible).EntireRow.Copy
            With wk
                  .Sheets(1).Range("a1").PasteSpecial
                  .SaveAs mf & "\" & arr(i, 1) & ".xls"
                  .Close False
            End With
         End If
      End If
Next
Cells.AutoFilter
Shell "Explorer " & mf, vbMaximizedFocus
Application.ScreenUpdating = True
End Sub  网上找的，怎样设置才能复制工作表的的标题栏的第一二行到每个拆分的工作表内

最佳答案

月排行榜 / 总排行榜

爱疯

2014-12-19 16:04

下载2楼链接里的最新附件，运行，就可看到

跳转到最佳答案楼层