怎么操作才能把数据写到相应模版工作表而生成新的工作表

Eenny

Option Explicit

Sub test()
  Dim filename(), i, j, k, m, a, b, arr
  If Not getfilename(ThisWorkbook.Path & "\shuju", filename, ".txt") Then MsgBox "请在shuju文件夹中指定存储位置！": Exit Sub
  Call events(False)
  ReDim brr(1 To UBound(filename) * 11, 1 To 11)
  m = 1
  For i = 1 To UBound(filename)
    Open filename(i) For Input As #1
    arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbNewLine)
    Close #1
    b = 0
    brr(m, 1) = filename(i)
    For j = 0 To UBound(arr)
      If InStr(arr(j), "要素") Or InStr(arr(j), "Element") Then
        a = 0: b = b + 1
        If b Mod 3 = 0 Then b = b + 1
        For k = j + 1 To UBound(arr)
          If InStr(arr(k), "=") Then
            a = a + 1
            brr(m + a, b) = Trim(Split(arr(k), "=")(1))
          End If
          If InStr(arr(k), "要素") Or InStr(arr(k), "Element") Then j = k - 1: Exit For
        Next
      End If
    Next
    m = m + 10
  Next
  '----------
  Dim sht, t
  For Each sht In Sheets
    If sht.Name <> "Sheet3" Then Sheets(sht.Name).Delete
  Next
  For i = 1 To UBound(brr, 1)
    If InStr(brr(i, 1), ".txt") Then
      t = Split(brr(i, 1), "\")
      t = Split(t(UBound(t)), ".")(0)
      Sheets.Add: ActiveSheet.Name = t
      ReDim crr(1 To 10, 1 To UBound(brr, 2))
      a = 0
      For j = i + 1 To UBound(brr, 1)
        a = a + 1
        For k = 1 To UBound(brr, 2): crr(a, k) = brr(j, k): Next
        If InStr(brr(j + 1, 1), ".txt") > 0 Or Len(brr(j + 1, 1)) = 0 Then i = j: Exit For
      Next
      ReDim drr(1 To UBound(brr, 2)): a = 0
      'For j = 1 To UBound(drr): a = a + 1: drr(j) = a: Next    '输出表头序号  隐藏
      With Sheets(t).[a7] '输出位置
        .Resize(, UBound(drr)) = drr
        .Offset(1).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
      End With
    End If
  Next
  Call events(True)
End Sub

Function events(flag)
  With Application
    .DisplayAlerts = flag
    .ScreenUpdating = flag
  End With
End Function

Function getfilename(pth, filename, mark) As Boolean
  Dim f, n
  pth = pth & IIf(Right(pth, 1) = "\", "", "\")
  f = Dir(pth & "*.*")
  Do Until Len(f) = 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function
上面的代码可以把数据分配到指定工作表中去，可以实现数据分类提取了。可是我现在有个指定模版，怎么修改才能每个工作表的数据在指定工作表内的单元格中。

Eenny

有没有人会呀？