微軟金牌OFFICE講師劉凌峰教你如何實(shí)現(xiàn)EXCEL離線模板收集數(shù)據(jù)

一、背景：
   許多客戶(hù)在使用系統(tǒng)時(shí)，可能需要大范圍收集資料。但可能受限于每個(gè)客戶(hù)并不是都能登錄系統(tǒng)，如外部供應(yīng)商，或只是臨時(shí)性的需要填寫(xiě)數(shù)據(jù)并不能要求每個(gè)用戶(hù)均安裝客端。這時(shí)，離線模板的作用就開(kāi)始生效了。
二、定義：
   離線模板是指用戶(hù)在填寫(xiě)數(shù)據(jù)時(shí)不需要登錄現(xiàn)有系統(tǒng)，在普通EXCEL環(huán)境下就能填寫(xiě)，填寫(xiě)完畢，可以通過(guò)一定的技術(shù)手段將數(shù)據(jù)導(dǎo)入到系統(tǒng)中。
三、實(shí)現(xiàn)過(guò)程：
   1、在系統(tǒng)中定義標(biāo)準(zhǔn)模板，并將模板單獨(dú)另存為EXCEL文件。
   2、通過(guò)公式引用 的方式，將模板中的表單數(shù)據(jù)轉(zhuǎn)換為清單數(shù)據(jù)，并指定區(qū)域名稱(chēng)。
   3、保護(hù)工作表相關(guān)區(qū)域，將文件分發(fā)給所有用戶(hù)。用戶(hù)填寫(xiě)數(shù)據(jù)，收回多個(gè)EXCEL文件。
   4、縮寫(xiě)導(dǎo)入數(shù)據(jù)VBA代碼，將多個(gè)EXCEL文件中的清單收集到另一個(gè)系統(tǒng)模板中。
四、參考代碼：
  Sub Import_data()
On Error Resume Next

Dim Fcount, Rcount As Long
'----------------------判斷是否有數(shù)據(jù)
Worksheets("本周完成情況").Activate
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Worksheets("下周計(jì)劃").Activate
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
 '------------------------打開(kāi)文件
Call openfile
'---------------------計(jì)算出總共有幾個(gè)文件需要導(dǎo)入
Worksheets("參數(shù)").Activate
Worksheets("參數(shù)").Range("a1").Select
Worksheets("參數(shù)").Range("a1").Activate
ActiveCell.CurrentRegion.Select
Set tbl = ActiveCell.CurrentRegion
Fcount = tbl.Rows.Count
'---------------------------開(kāi)始循環(huán)導(dǎo)入數(shù)據(jù)文件
For I = 1 To Fcount
'---------------------------獲取需要導(dǎo)入的文件名
Fname = Sheets("參數(shù)").Cells(I, 1)
'---------------------------計(jì)算并定位行號(hào)
Worksheets("本周完成情況").Activate
Range("A1").Select
Range("A1").Activate
ActiveCell.CurrentRegion.Select
Set tbl = ActiveCell.CurrentRegion
Rcount = tbl.Rows.Count + 1
 '－－－－－－－－－－－－－－－－－－－開(kāi)始導(dǎo)入
  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
 
   '--------將查詢(xún)區(qū)域的字段名移除并刷新數(shù)據(jù)源沒(méi)有標(biāo)題行。
Cells(Rcount, 1).Select
    With Selection.QueryTable
        .FieldNames = False
    End With
Selection.QueryTable.Refresh BackgroundQuery:=False
   
'----------導(dǎo)下周計(jì)劃
Worksheets("下周計(jì)劃").Activate
Range("A1").Select
Range("A1").Activate
ActiveCell.CurrentRegion.Select
Set tbl = ActiveCell.CurrentRegion
Rcount = tbl.Rows.Count + 1
'－－－－－－－－－－－－－－－－－－－開(kāi)始導(dǎo)入
  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("下周計(jì)劃$")
        .Name = "下周計(jì)劃"
        .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
   '--------將查詢(xún)區(qū)域的字段名移除并刷新數(shù)據(jù)源沒(méi)有標(biāo)題行。
Cells(Rcount, 1).Select
    With Selection.QueryTable
        .FieldNames = False
    End With
Selection.QueryTable.Refresh BackgroundQuery:=False

Next I
'設(shè)置已用區(qū)域邊框線
Sheets("本周完成情況").Select
Call Set_borders
Sheets("下周計(jì)劃").Select
Call Set_borders
Sheets("控制臺(tái)").Select
Exit Sub
End Sub

Sub openfile()
    Worksheets("參數(shù)").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("參數(shù)").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