微軟金牌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