关于表格自动拆分并发送邮件问题 在线等。。。

wj2368

R-AX列，原没数据

tztz163

有数据的，请看分表之后的其中一个文件与原文件的对比

tztz163

wj2368老师，以下是我在其他地方搜集到的分表代码，但是无奈不会编程，无法参透，请老师过目，是否有值得借鉴的地方？

Sub 按照总表A列数据分类存到各新表()
Dim irow, irow1, i, j As Integer
Dim H As New Collection
Dim sht As Worksheet
Dim A
'Worksheets("总表").Select
'Selection.QueryTable.Refresh BackgroundQuery:=False
Set A = ActiveCell
Application.ScreenUpdating = False
Application.DisplayAlerts = False    '禁用警告框
For Each sht In Sheets
If sht.Name <> "总表" Then sht.Delete
Next
Sheets("总表").Copy Before:=Sheets(1)

On Error Resume Next
    With Sheets("总表 (2)")
        irow = [a65536].End(xlUp).Row
        For i = 4 To irow
           .Cells(i, 1) = "'" & .Cells(i, 1)
        Next
        For i = 4 To irow
           H.Add .Cells(i, 1), CStr(.Cells(i, 1))
        Next
  For i = 1 To H.Count
    .Cells.AutoFilter field:=1, Criteria1:=H(i)
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = H(i)
    .[a4].CurrentRegion.Copy Sheets(CStr(H(i))).[a4]
    irow1 = [a4].CurrentRegion.Rows.Count
    For t = 1 To [a4].CurrentRegion.Columns.Count
        Cells(1, t).ColumnWidth = .Cells(1, t).ColumnWidth
        Next t
    For j = 2 To irow1
       Cells(j, 1) = Right(Cells(j, 1), Len(Cells(j, 1)))
    Next j
    .Cells.AutoFilter
  Next i
  .Delete
  End With
  A.Parent.Activate
  A.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

wj2368

你测试一下，行不

tztz163

很奇怪，用你的表格是可以的，但是我试用了自己表格就不行了，不知道问题出在哪里。
上传你的表格和我的表格，请wj2368老师过目

wj2368

你把你自己的表格排序一下，在R-AX列中有数据的排在前面就可以了

mineshine

试看看加一个imex=1参数
Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;';Data Source=" & ThisWorkbook.FullName
改
Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;imex=1';Data Source=" & ThisWorkbook.FullName

tztz163

恩，我明天就去单位试试，谢谢mineshine老师

tztz163

Mineshine老师，我试用之后，发现原本缺失的数字部分，现在已经填充上去了，但是填充上去的是以文本形式存在的，这样还是略显不便，不知自动分表后可以改为数字形式吗？
已上传附件供参考

mineshine

SQL语句得到的皆是文本形式