微软金牌OFFICE讲师刘凌峰教你如何实现EXCEL离线模板收集数据

一、背景：
   许多客户在使用系统时，可能需要大范围收集资料。但可能受限于每个客户并不是都能登录系统，如外部供应商，或只是临时性的需要填写数据并不能要求每个用户均安装客端。这时，离线模板的作用就开始生效了。
二、定义：
   离线模板是指用户在填写数据时不需要登录现有系统，在普通EXCEL环境下就能填写，填写完毕，可以通过一定的技术手段将数据导入到系统中。
三、实现过程：
   1、在系统中定义标准模板，并将模板单独另存为EXCEL文件。
   2、通过公式引用 的方式，将模板中的表单数据转换为清单数据，并指定区域名称。
   3、保护工作表相关区域，将文件分发给所有用户。用户填写数据，收回多个EXCEL文件。
   4、缩写导入数据VBA代码，将多个EXCEL文件中的清单收集到另一个系统模板中。
四、参考代码：
  Sub Import_data()
On Error Resume Next

Dim Fcount, Rcount As Long
'----------------------判断是否有数据
Worksheets("本周完成情况").Activate
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Worksheets("下周计划").Activate
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
 '------------------------打开文件
Call openfile
'---------------------计算出总共有几个文件需要导入
Worksheets("参数").Activate
Worksheets("参数").Range("a1").Select
Worksheets("参数").Range("a1").Activate
ActiveCell.CurrentRegion.Select
Set tbl = ActiveCell.CurrentRegion
Fcount = tbl.Rows.Count
'---------------------------开始循环导入数据文件
For I = 1 To Fcount
'---------------------------获取需要导入的文件名
Fname = Sheets("参数").Cells(I, 1)
'---------------------------计算并定位行号
Worksheets("本周完成情况").Activate
Range("A1").Select
Range("A1").Activate
ActiveCell.CurrentRegion.Select
Set tbl = ActiveCell.CurrentRegion
Rcount = tbl.Rows.Count + 1
 '－－－－－－－－－－－－－－－－－－－开始导入
  With ActiveSheet.QueryTables.Add(Connection:=Array( _
        "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=" & Fname & ";" _
        , _
        "Mode=Share Deny Write;Extended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database " _
        , _
        "Password="""";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk" _
        , _
        " Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet O" _
        , _
        "LEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
        ), Destination:=Cells(Rcount, 1))
        .CommandType = xlCmdTable
        .CommandText = Array("本周完成情况$")
        .Name = "本周完成"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = Fname
        .Refresh BackgroundQuery:=False
    End With
 
   '--------将查询区域的字段名移除并刷新数据源没有标题行。
Cells(Rcount, 1).Select
    With Selection.QueryTable
        .FieldNames = False
    End With
Selection.QueryTable.Refresh BackgroundQuery:=False
   
'----------导下周计划
Worksheets("下周计划").Activate
Range("A1").Select
Range("A1").Activate
ActiveCell.CurrentRegion.Select
Set tbl = ActiveCell.CurrentRegion
Rcount = tbl.Rows.Count + 1
'－－－－－－－－－－－－－－－－－－－开始导入
  With ActiveSheet.QueryTables.Add(Connection:=Array( _
        "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=" & Fname & ";" _
        , _
        "Mode=Share Deny Write;Extended Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database " _
        , _
        "Password="""";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk" _
        , _
        " Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet O" _
        , _
        "LEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
        ), Destination:=Cells(Rcount, 1))
        .CommandType = xlCmdTable
        .CommandText = Array("下周计划$")
        .Name = "下周计划"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = Fname
        .Refresh BackgroundQuery:=False
    End With
   '--------将查询区域的字段名移除并刷新数据源没有标题行。
Cells(Rcount, 1).Select
    With Selection.QueryTable
        .FieldNames = False
    End With
Selection.QueryTable.Refresh BackgroundQuery:=False

Next I
'设置已用区域边框线
Sheets("本周完成情况").Select
Call Set_borders
Sheets("下周计划").Select
Call Set_borders
Sheets("控制台").Select
Exit Sub
End Sub

Sub openfile()
    Worksheets("参数").Select
    Range("a1:a1000").Select
    Selection.Delete
    Dim lngCount As Long
    ' Open the file dialog
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
        ' Display paths of each file selected
      For lngCount = 1 To .SelectedItems.Count
      Fname = .SelectedItems(lngCount)
      Worksheets("参数").Cells(lngCount, 1) = Fname
        Next lngCount
    End With
End Sub

Sub Set_borders()
ActiveSheet.UsedRange.Select
With Selection
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
End Sub