拆分工作表问题

touchforever

我需要的就是一个表格，从开始往下，第一行第一列的内容作为一个拆分保存的文件名，往下，如果发现一个空行（有可能第一列有空格，但第二列或者第三列有内容，就不算空行），将以上内容拆分存为一个文件，然后再重新向下，以此类推。

xiangbaoan

touchforever 发表于 2021-1-17 17:19
谢谢，不过拆分以后的最后行的第一列有的为空的，不知道为什么。

touchforever

也可能是自己表达的不太清楚

3190496160

任何人写代码，只能是根据你上传附件的特点来写，你事先也沒说明具体的情况

touchforever

3190496160 发表于 2021-1-17 21:28
任何人写代码，只能是根据你上传附件的特点来写，你事先也沒说明具体的情况

真不好意思，是我的问题，麻烦你了。

touchforever

xiangbaoan 发表于 2021-1-17 17:24

请问，生成的新文件中表格的框线没有了，怎么解决呀？

xiangbaoan

touchforever 发表于 2021-1-18 09:10
请问，生成的新文件中表格的框线没有了，怎么解决呀？

我那是SQL，拆分快，要框线是没法的，

touchforever

xiangbaoan 发表于 2021-1-18 09:15
我那是SQL，拆分快，要框线是没法的，

噢，再次感谢。

xiangbaoan

touchforever 发表于 2021-1-18 09:22
噢，再次感谢。

Sub test2() '不用谢的，保留格式，仅参考
  Dim p As String, f As String, s As String, ar, br, i As Long, j As Long, Ran As Range
  DoApp False
  p = ThisWorkbook.Path & "\拆分文件夹"
  If Dir(p, vbDirectory) = "" Then MkDir p
  br = Range("A1").CurrentRegion.Offset(1).Resize(1)
  For j = 1 To UBound(br, 2)
    br(1, j) = Columns(j).ColumnWidth
  Next
  ar = Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp))
  For i = 2 To UBound(ar)
    If ar(i, 1) = "学号" Then
      s = ar(i - 1, 1)
      f = p & Application.PathSeparator & s & ".xlsx"
      Set Ran = Cells(i, 1).CurrentRegion.Offset(1)
      If Dir(f) <> "" Then Kill f
      With Workbooks.Add
        With .Worksheets(1)
          Ran.Copy
          .Range("A1").PasteSpecial 13
          .Range("A1").PasteSpecial 12
          For j = 1 To UBound(br, 2)
          .Columns(j).ColumnWidth = br(1, j)
          Next
          .Name = s
        End With
        .SaveAs f, 51
        .Close
      End With
    End If
  Next
  Set Ran = Nothing
  DoApp
  MsgBox "ok! 文件位于:" & vbCr & p, 64
End Sub

Function DoApp(Optional b As Boolean = True)
  With Application
    .ScreenUpdating = b
    .DisplayAlerts = b
    If b = True Then .Calculation = -4105 Else .Calculation = -4135
  End With
End Function

xiangbaoan

touchforever 发表于 2021-1-18 09:22
噢，再次感谢。

换了一种方法.rar (16.76 KB, 下载次数: 23)

2021-1-18 09:46 上传

点击文件名下载附件