注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

VBA 分割 xlsx 超百万数据程序  

2012-03-29 18:08:05|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

VBA 分割 xlsx 超百万数据程序

 

Option Explicit
 Sub s()
    On Error Resume Next
    Dim oRecrodset
    Dim arr
    Dim sConStr As String
    Dim sSql As String
    Dim oWk As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim sFN As String
    Dim Sname As String
   
    Application.DisplayAlerts = False
    Sname = ActiveSheet.Name
    For Each oWk In Application.Worksheets
        If oWk.Name <> Sname Then
            oWk.Delete
        End If
    Next
    Application.DisplayAlerts = True
    sFN = Xyf_GetFieldName()
    If Err.Number = 424 Then
        Exit Sub
    End If
    sConStr = "Provider='Microsoft.ACE.OLEDB.12.0';Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0

Xml;HDR=YES;IMEX=1'"
  '  Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;Extended Properties="Excel 12.0

Xml;HDR=YES;IMEX=1";
    sSql = "select distinct " & sFN & " from [" & Sname & "$]"
    Set oRecrodset = CreateObject("ADODB.Recordset")
    With oRecrodset
        .Open sSql, sConStr
        arr = .getrows
        .Close
        For i = 0 To UBound(arr, 2)
            On Error GoTo solution
            sSql = "select * from [" & Sname & "$] where " & sFN & "='" & arr(0, i) & "'"
            .Open sSql, sConStr
            Set oWk = ThisWorkbook.Worksheets.Add(After:=ActiveSheet)
            oWk.Name = arr(0, i)
            For j = 1 To .Fields.Count
                oWk.Cells(1, j) = .Fields(j - 1).Name
                If .Fields(j - 1).Type = 7 Then
                    oWk.Cells(1, j).EntireColumn.NumberFormat = "yyyy-mm-dd"
                End If
            Next
            oWk.Cells(2, 1).CopyFromRecordset oRecrodset
            oWk.Columns.AutoFit
            .Close
        Next
    End With
    Set oRecrodset = Nothing
    Exit Sub
solution:
    MsgBox "你选择的字段不适合用来拆分总表,请重新选择!"
End Sub
Function Xyf_GetFieldName()
    Dim oRng As Range
    Set oRng = Application.InputBox(prompt:="请你选择要根据哪个字段拆分销售汇总表?", Title:="拆分总表", Type:=8)
    With oRng
        If .Columns.Count = 1 Then
            Xyf_GetFieldName = oRng.End(xlUp).Value
        End If
    End With
End Function


 

  评论这张
 
阅读(676)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017