使用VBA给EXCEL处理数据

桐羽sama

lsc900707 发表于 2017-3-3 16:52
把除sheet1以外的表先行删除

已经解决，谢谢老师的指导！

WANT-T

这是我给你提供的方法，处理完成之后 ，需要把时间那列处理一下，excel给转成科学计数了，这个应该是小问题，
下面是代码，复制到模块直接运行就行

1. Option Explicit
   
2. 
   
3. Sub 拆分()
   
4.     Dim sh As Worksheet, Arr(), i%, item
   
5.     Dim Adoconn As Object, AdoRet As Object, dic As Object
   
6.     Dim StrConn As String, StrSQL As String
   
7.     '屏蔽警告和刷新
   
8.     Application.DisplayAlerts = False
   
9.     Application.ScreenUpdating = False
   
10.     '只保留Sheet1工作表，其它工作表都删除，也可以手动删除，然后注释掉这几句代码
    
11.     For Each sh In Sheets
    
12.         If sh.Name <> "Sheet1" Then sh.Delete
    
13.     Next
    
14.     '创建对象
    
15.     Set Adoconn = CreateObject("ADODB.Connection")
    
16.     Set AdoRet = CreateObject("ADODB.Recordset")
    
17.     Set dic = CreateObject("Scripting.Dictionary")
    
18.     '获取数组
    
19.     With Worksheets("Sheet1")
    
20.         Arr = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    
21.     End With
    
22.     '利用字典来提取唯一站号
    
23.     For i = 1 To UBound(Arr)
    
24.         dic(Arr(i, 1)) = ""
    
25.         DoEvents
    
26.     Next
    
27.    
    
28.     '连接字符串根据自己的excel版本自行选择
    
29.     'excel2007及以上版本
    
30.     StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"
    
31.     'excel2003版本
    
32.     'StrConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0;HDR=YES"";"
    
33.     Adoconn.Open StrConn '打开数据库连接
    
34.     For Each item In dic.keys
    
35.         StrSQL = "SELECT * FROM [Sheet1$] WHERE 站号=" & item
    
36.         With Worksheets.Add(after:=Sheets(Sheets.Count))
    
37.             .Name = item
    
38.             AdoRet.Open StrSQL, Adoconn, 1, 1
    
39.             '获取字段名称
    
40.             For i = 1 To AdoRet.Fields.Count
    
41.                 .Cells(1, i) = AdoRet.Fields(i - 1).Name
    
42.                 DoEvents
    
43.             Next i
    
44.             '将获取查询到的记录写入单元格内
    
45.             .Range("A2").CopyFromRecordset AdoRet
    
46.             AdoRet.Close
    
47.         End With
    
48.     Next
    
49.     Adoconn.Close '关闭数据库连接
    
50.     '释放变量
    
51.     Set Adoconn = Nothing
    
52.     Set AdoRet = Nothing
    
53.     Set dic = Nothing
    
54.     '恢复警告和刷新
    
55.     Application.DisplayAlerts = True
    
56.     Application.ScreenUpdating = True
    
57.     MsgBox "FINISH！"
    
58. End Sub

复制代码

桐羽sama

lsc900707 发表于 2017-3-3 16:52
把除sheet1以外的表先行删除

老师您好，现在我想求取每一个工作表中的几列的平均值，放在该列末端，比如温度，但是有一些是没有数值用///代替的就不求，能在原本的代码的基础上修改实现吗？或者是单独一个工作表中实现也可以，就是列求平均值放在该列末端

lsc900707

很简单的问题，不过只能晚上用电脑回复你。

桐羽sama

lsc900707 发表于 2017-3-6 11:13
很简单的问题，不过只能晚上用电脑回复你。

好的，谢谢老师

lsc900707

桐羽sama 发表于 2017-3-6 11:26
好的，谢谢老师

Private Sub CommandButton1_Click()
    Dim tim1 As Date, tim2 As Date: tim1 = Timer
    Dim arr, d As Object, sht As Worksheet
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Range("a" & i).Resize(1, 94)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 94))
        End If
    Next
    x = d.keys
    For k = 1 To UBound(x)
        Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
        sht.Name = x(k)
        d.items()(k).Copy sht.Range("a" & 2)
        Rows("1:1").Copy sht.[a1]
    Next
    For Each sht In Sheets
        If sht.Name <> "Sheet1" Then
           With sht
              k = .Cells(.Rows.Count, 1).End(xlUp).Row
              arr = .[a1].CurrentRegion
              For i = 2 To UBound(arr)
                  For j = 6 To UBound(arr, 2)
                     If IsNumeric(.Cells(i, j)) Then
                         .Cells(k + 1, j) = Application.Average(Application.Index(arr, , j))
                     End If
                  Next
              Next
            End With
        End If
    Next
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

桐羽sama

lsc900707 发表于 2017-3-6 21:48
Private Sub CommandButton1_Click()
    Dim tim1 As Date, tim2 As Date: tim1 = Timer
    Dim arr, ...

感谢老师的帮助与指导！完美解决了学生的问题！

lsc900707

桐羽sama 发表于 2017-3-7 09:04
感谢老师的帮助与指导！完美解决了学生的问题！

不必拘礼，解决了问题就好。呵呵。