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 '结束函数