VBA导入

Sub 手动导入表() selectfiles = Application.GetOpenFilename("," & ".", , "打开", , True) '选择文件 If TypeName(selectfiles) = "Boolean" Then '若未选择则结束程序运行 Exit Sub End If

关闭功能
For fi = 1 To UBound(selectfiles)
    Call 导入表(selectfiles(fi), 路径文件名(selectfiles(fi)))
Next
开启功能

End Sub

Function 导入表(fp, s) 'fp导入文件路径,s导入表名 s = s & "" '导入表名 连接空白是避免表格名为数值时格式不同 If Dir(fp, 16) = Empty Then Exit Function '路径不存在不运行

c = 1 '默认1,表不存在时默认用第一行决定填充公式行数
If Right(fp, Len(fp) - InStrRev(fp, ".")) = "csv" Then 'csv文件导入
    If 表存在(s) Then
        v1 = Split(readline(fp, 1), ",")(0)
        Sheets(s).Select
        c = Application.Match(v1, [1:1], 0)
        If IsError(c) Then
            导入表 = "找不到对应标题列"
            Exit Function
        End If
        Cells(1, c).Select
        Call csv导入(fp, Selection) '防止数值大于15位时丢失精度所以用导入
    Else
        ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(Sheets.Count)
        ActiveSheet.Name = s
        Call csv导入(fp, Selection, True) '防止数值大于15位时丢失精度所以用导入
    End If
    
Else '非csv文件导入
    Set wb = Workbooks.Open(fp) '打开文件
    Range([A:A], [A:A].End(xlToRight)).Copy '已经选择整列所以不用清除元数据
    v1 = [A1] '用于查找对应列
    ThisWorkbook.Activate
    
    If 表存在(s) Then
        Sheets(s).Select
        c = Application.Match(v1, [1:1], 0)
        If IsError(c) Then
            导入表 = "找不到对应标题列"
            Application.CutCopyMode = False
            wb.Close 0
            Exit Function
        End If
        Cells(1, c).Select
        Application.DisplayAlerts = False '禁用警告信息
        Sheets(s).Paste '损益的表粘贴时会警告此处已有数据所以屏蔽
        Application.DisplayAlerts = True '启用警告信息
        Application.CutCopyMode = False
        wb.Close 0
    Else
        Application.DisplayAlerts = False '禁用警告信息
        wb.Sheets(1).Move After:=ThisWorkbook.Sheets(Sheets.Count)
        Application.DisplayAlerts = True '启用警告信息
        ActiveSheet.Name = s
    End If
    
End If

'填充公式
rn = Cells(1048576, c).End(xlUp).Row
Call 相邻公式填充(c)
c = Cells(2, c).CurrentRegion.Columns.Count + 1
Call 相邻公式填充(c)

End Function

Function 表存在(s) For Each i In Sheets If i.Name = s & "" Then 表存在 = 1 '连接空白是避免表格名为数值时格式不同 ' Debug.Print i.Name = s Next End Function

Function 建表(s) For Each i In Sheets If i.Name = s Then Exit Function Next Sheets.Add(, ThisWorkbook.Sheets(Sheets.Count)).Name = s ' Sheets.Add.Name = s'创建在前面 ' Sheets.Add 方法 (Excel):https://msdn.microsoft.com/zh-cn/library/office/ff839847 End Function

Sub 相邻公式填充(Optional ByVal c, Optional d, Optional r, Optional rn) If IsMissing(c) Then c = Cells.CurrentRegion.Columns.Count + 1 If IsMissing(d) Then d = -1 If IsMissing(r) Then r = 2 If IsMissing(rn) Then rn = Cells(r, c).CurrentRegion.Rows.Count Do c = c + d If c < 1 Then Exit Do If Cells(r, c) = Empty Then Exit Do If Application.IsFormula(Cells(r, c)) Then Cells(r, c).AutoFill Destination:=Cells(r, c).Resize(rn - 1, 1) Else Exit Do End If Loop End Sub

Sub csv导入(fp, rg, Optional ACW) 'fp导入文件路径,rg导入单元格位置,ACW调整列宽 If IsMissing(ACW) Then ACW = Flase If Dir(fp, 16) = Empty Then Exit Sub '路径不存在不运行 With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fp, Destination:=rg) ' .CommandType = 0 .Name = "1" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = True '填充相邻公式 .PreserveFormatting = True '保持格式设置 .RefreshOnFileOpen = False '文件打开时刷新 .RefreshStyle = xlOverwriteCells '插入模式=覆盖(还有插入行和插入列选择) .SavePassword = False .SaveData = True .AdjustColumnWidth = ACW '调整列宽 .RefreshPeriod = 0 '刷新周期 .TextFilePromptOnRefresh = False .TextFilePlatform = 936 '文件平台??? .TextFileStartRow = 1 '文件开始行 .TextFileParseType = xlDelimited '文件类型 .TextFileTextQualifier = xlTextQualifierDoubleQuote '文本文件的文本限定符 .TextFileConsecutiveDelimiter = False ' .TextFileTabDelimiter = False 'Tab键 .TextFileSemicolonDelimiter = False '分号 .TextFileCommaDelimiter = True '逗号 .TextFileSpaceDelimiter = False '空格

    '读取第二行
    tl = Split(readline(fp, 2), ",")
    ReDim arr(UBound(tl))
    rg.Resize(1048576, UBound(tl) + 1).ClearContents '清除原数据列2017年2月8日
    For ti = 0 To UBound(tl)
        If Len(tl(ti)) > 15 Then
            arr(ti) = 2 '如果位数大于15位的数字导入格式为文本
        Else
            arr(ti) = 1
        End If
    Next
    
    .TextFileColumnDataTypes = arr
    .TextFileTrailingMinusNumbers = True '文本文件尾随减去数字???
    .Refresh BackgroundQuery:=False '刷新后台查询
    .Delete '删除查询定义,没办法录制到语句补充2017年2月8日
End With

End Sub

Function readline(fp, line) '读取文件某行 Set FileObj = CreateObject("Scripting.FileSystemObject") Set TextObj = FileObj.OpenTextFile(fp) For i = 1 To line If Not TextObj.AtEndOfLine Then readline = Trim(TextObj.readline) '2017年2月9日防止只有一行报错 Next End Function

Function ReadUTF(ByVal FileName As String) As String With CreateObject("ADODB.Stream") .Type = 2 '读取文本文件 .Mode = 3 '读写 .Open '打开流 .LoadFromFile FileName '装载文本文件 .Charset = "UTF-8" '设定编码 .Position = 2 ReadUTF = .ReadText '读取文本 .Close '关闭 End With End Function

'VBA函数与过程简洁教程

Sub 过程名() 'Sub表示过程,在执行宏或图形右击指定宏中看得到,不能返回值

Call 函数名(Array(1, 2), b) '调用过程并把返回值放入r

End Sub '结束过程

Function 函数名(a, Optional ByVal b) 'Function表示函数,在单元格中也可以使用,宏列表看不到,可以使宏列表简洁 'VBA默认ByRef会改变原参数的值,所以加了ByVal

If IsMissing(b) Then b = 1 '为加了Optional的可选择性省略参数设定值

ReDim arr(UBound(a)) '定义可变数组,UBound()是求最大下标值

arr(1) = b

函数名 = arr '返回值,仅Function可用

Exit Function '退出函数,不要用return,return是在一个程序中回到GoSub后一行

End Function '结束函数

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

相关文章

来自专栏流柯技术学院

python批量下载图片的三种方法

win32com可以获得类似js里面的document对象,但貌似是只读的(文档都没找到)。

832
来自专栏用户2442861的专栏

PyQt4 - (2) 第一印象 (pyqt的入门)

http://www.blogjava.net/glorywine/archive/2008/06/21/206729.html

501
来自专栏张善友的专栏

Spacebuilder在Mono上运行修改备忘

Spacebuilder 是一个asp.net mvc3项目,使用到了Combres,Combres依赖于dotless,然后在Spacebuilder的项目没...

1956
来自专栏python学习路

六、BeautifulSoup4------自动登录网站(手动版)

每天一个小实例:(按照教学视频上自动登录的网站,很容易就成功了。自已练习登录别的网站,问题不断) 这个自己分析登录boss直聘。我用了一下午的时间,而且还是手动...

3735
来自专栏Android Note

Kotlin与Databinding(一)简介封装

1033
来自专栏Young Dreamer

VUE中的v-if与v-show

1.共同点 都是动态显示DOM元素 2.区别 (1)手段:v-if是动态的向DOM树内添加或者删除DOM元素;v-show是通过设置DOM元素的display样...

1827
来自专栏破晓之歌

React组件(推荐,差代码) 原

react官方教程:https://reactjs.org/tutorial/tutorial.html

622
来自专栏程序员的SOD蜜

实体类的枚举属性--原来支持枚举类型这么简单,没有EF5.0也可以

    通常,我们都是在业务层和界面层使用枚举类型,这能够为我们编程带来便利,但在数据访问层,不使用枚举类型,因为很多数据库都不支持,比如我们现在用的SqlSe...

20310
来自专栏Jackson0714

01.策略模式-上篇

3308
来自专栏葡萄城控件技术团队

值得 .NET 开发者了解的15个特性

本文列举了 15 个值得了解的 C# 特性,旨在让 .NET 开发人员更好的使用 C# 语言进行开发工作。 1. ObsoleteAttribute Obsol...

3449

扫码关注云+社区