VBA 标准表达式中数据类型不匹配- 将一个工作表的数据分割在几个不同的工作表

stusun

我想使用VBA将一个工作表中的数据按照不同的代号分割在多个工作表，但是在运行VBA时提示，有创建一个新的工作表，但是数据未拷贝到新生成的工作表中，且运行以下这一语句时提示“标准表达式中数据类型不匹配”， 程序无法往以下执行。
.Range("A2").CopyFromRecordsetconn.Execute(Sql)


数据分割的要求是将工作表中的数据按照一列中不同的编号将所有数据分成单独的工作表

xuemei0216

Sub a()
Application.ScreenUpdating = False
Dim sht As Worksheet
Application.DisplayAlerts = False
    If Sheets.Count > 1 Then    '工作簿必须，至少有一个工作表
        For Each sht In Sheets
            If sht.Name <> Sheets(1).Name Then sht.Delete           '删除工作表，除第一个表外的所有表
        Next
    End If
Application.DisplayAlerts = True
'整列，存入字典
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Dim arr, i%
arr = [a1].CurrentRegion    '数据源
For i = 2 To UBound(arr)     '不含标题
        d(arr(i, 1)) = ""
Next
'拆分
Set sht = ActiveSheet     '当前工作表
With sht
    For i = 0 To d.Count - 1
        Worksheets.Add(after:=Sheets(Sheets.Count)).Name = d.keys()(i)        '新建，工作表并命名
        .[a1].CurrentRegion.AutoFilter Field:=1, Criteria1:=d.keys()(i)        '筛选
        .[a1].CurrentRegion.Copy [a1]
    Next
    .[a1].CurrentRegion.AutoFilter          '取消筛选
    .Select          '显示当前表
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox prompt:="按【" & Cells(1, 1).Value & "】，拆分完成！", Title:="提示"
End Sub

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim sh As Worksheet, strShName As String, strAddress As String
   
5.     Dim Conn As Object, Rst As Object, strPath As String
   
6.     Dim strConn As String, strSQL As String
   
7.     Dim lngRows As Long, lngCols As Long
   
8.     Dim arrTitle As Variant '标题区域
   
9.     Dim arrType As Variant '类型，用于命名工作表
   
10.     Dim lngID As Long, strFind As String
    
11.    
    
12.     strShName = "数据源"
    
13.     Set sh = Sheets(strShName)
    
14.     lngRows = sh.Range("A1").CurrentRegion.Rows.Count - 1 '采用无标题行的方式，所以总行数要减1
    
15.     lngCols = sh.Range("A1").CurrentRegion.Columns.Count
    
16.    
    
17.     arrTitle = sh.Range("A1").Resize(1, lngCols) '读取标题行
    
18.     strAddress = sh.Range("A2").Resize(lngRows, lngCols).Address(0, 0) '获取数据区域地址
    
19.    
    
20.     Set Conn = CreateObject("ADODB.Connection")
    
21.     Set Rst = CreateObject("ADODB.Recordset")
    
22.     strPath = ThisWorkbook.FullName
    
23.     Select Case Application.Version * 1
    
24.         Case Is <= 11
    
25.             strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
    
26.         Case Is >= 12
    
27.             strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=NO"";"""
    
28.     End Select
    
29.     Conn.Open strConn
    
30. 
    
31.     '获取代号
    
32.     strSQL = "SELECT [F1] FROM [" & strShName & "$" & strAddress & "]  GROUP BY [F1];"
    
33.     If Rst.State = 1 Then Rst.Close
    
34.     Rst.Open strSQL, Conn, 3, 1 '执行查询，并将结果输出到记录集对象
    
35.    
    
36.     If Rst.RecordCount = 0 Then
    
37.         Set Rst = Nothing
    
38.         Set Conn = Nothing
    
39.         MsgBox "无数据！", vbInformation + vbOKOnly, "提示"
    
40.         Exit Sub
    
41.     End If
    
42.    
    
43.     arrType = Rst.GetRows
    
44.    
    
45.     For lngID = LBound(arrType, 2) To UBound(arrType, 2)
    
46.         strFind = arrType(0, lngID)
    
47.         '逐个类型读取数据，并写入不同的表
    
48.         strSQL = "SELECT * FROM [" & strShName & "$" & strAddress & "]  WHERE [F1] Like '" & strFind & "';"
    
49.         If Rst.State = 1 Then Rst.Close
    
50.         Rst.Open strSQL, Conn, 3, 1 '执行查询，并将结果输出到记录集对象
    
51.         FullDataToSheet strFind, arrTitle, Rst
    
52.     Next
    
53.    
    
54.     Set Rst = Nothing
    
55.     Set Conn = Nothing
    
56.    
    
57.     MsgBox "OK"
    
58. End Sub
    
59. 
    
60. Function FullDataToSheet(strShName As String, arrTitle As Variant, arrData As Object)
    
61.     Dim sh As Worksheet
    
62.    
    
63.     On Error Resume Next
    
64.    
    
65.     If Not Sheets(strShName) Is Nothing Then
    
66.         If Err.Number <> 9 Then
    
67.             Set sh = Sheets(strShName)
    
68.         Else
    
69.             Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
    
70.             sh.Name = strShName
    
71.         End If
    
72.         Err.Clear
    
73.     End If
    
74.    
    
75.     sh.UsedRange.Clear
    
76.     sh.Range("A1").Resize(UBound(arrTitle), UBound(arrTitle, 2)) = arrTitle '标题
    
77.     sh.Range("A2").CopyFromRecordset arrData '数据
    
78.    
    
79.     Set sh = Nothing
    
80. End Function
    
81. 
    

复制代码

stusun

xuemei0216 发表于 2019-9-29 11:50
Sub a()
Application.ScreenUpdating = False
Dim sht As Worksheet

您好，真的非常，您写的代码可以运行，不过有个问题是现在按照这个代码运行只能分两个工作表，因为根据实际的编号应该分出几十个工作表，但是实际只分出来两个工作表。

xuemei0216

stusun 发表于 2019-9-29 13:56
您好，真的非常，您写的代码可以运行，不过有个问题是现在按照这个代码运行只能分两个工作表，因为根据实 ...

不是按第一列拆分吗？第一列就只有1跟2这两个呀。你要按第几列拆分

fanyoulin

我测试了4楼的代码，真的写的很专业，高手就是高手。
sql要用好其实很不容易，尤其是楼主这类不太严谨的数据。之所以说不严谨，是因为楼主的标题大量用的都是这种，比如“strip position on entry of VAAT plant []”，我可以说新手100%会被搞晕；
[]可以看做是sql的专用操作符，这么说肯定不严谨，但实际上你在标题上用了[]就会非常的麻烦。我本来想看看4楼是如何操作[]的，但4楼回避了这个问题，采用了无标题的方式来查询，我只能说：高；
sql还有一个很容易出错的就是日期，excel支持的日期l类似 #2019/06/25# 这样的，所以写日期条件需要写成 " 日期 between #" & 第一个日期变量 & "# and #" &  第二个日期变量 & "#"，如果是用引号来引用日期通常就不行；

stusun

xuemei0216 发表于 2019-9-29 15:34
不是按第一列拆分吗？第一列就只有1跟2这两个呀。你要按第几列拆分

是的，我只需要按照第一列进行拆分，但是如果我增加数据，按照这种方式拆分的话也只能拆分两个工作表。

stusun

fanyoulin 发表于 2019-9-29 16:29
我测试了4楼的代码，真的写的很专业，高手就是高手。
sql要用好其实很不容易，尤其是楼主这类不太严谨的数 ...

您评价的非常到位，我是一个新手，所以数据处理也很不严谨。4楼的代码真的非常适用，今天真的学到很多，谢谢你们的指点。

xuemei0216

stusun 发表于 2019-9-30 10:21
是的，我只需要按照第一列进行拆分，但是如果我增加数据，按照这种方式拆分的话也只能拆分两个工作表。

怎么可能，第一列是整列都存入字典的。除非你新增的还是1跟2