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