Vba 使用宏拆分工作簿以使用模板分隔文件

我需要一个宏来将我的数据从一个Excel文件拆分为几个其他文件。看起来是这样的：

     UserList.xls

User    Role    Location
DDAVIS  XX       WW
DDAVIS  XS       WW
GROBERT XW       WP
SJOBS   XX       AA
SJOBS   XS       AA
SJOBS   XW       AA

我需要，像这样复制数据：

     WW_DDAVIS.xls 

User    Role     
DDAVIS  XX
DDAVIS  XS

     WP_GROBERT.xls
User    Role
GROBERT XW

     AA_SJOBS.xls
User    Role
SJOBS   XX
SJOBS   XS
SJOBS   XW

我需要每个用户都有自己的文件。当我被告知需要使用模板（template.xls）填充文件时，问题出现了。看起来相同，但源文件中的数据从单元格A2开始，模板文件中的数据从单元格A8开始

要复制没有模板的数据，我使用以下代码：

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1

            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0

            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If

    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Exit
        Exit Do
    End If
Loop

'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " documents saved in " + sFilePath


End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub


Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook

     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet

     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Select left-topmost cell
     ash.Cells(1, 1).Select

     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")

     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub

这可能有用。我还没有测试代码。这有点粗糙。我也是vba的初学者。如果有错误，请原谅我。 看看逻辑。如果您只想从头开始创建代码。

@Sivaprasath V 谢谢，看起来应该有用。我对它做了一点修改，使它看起来更好，并解决了一些问题

Sub test()
Dim wb
Dim temp
Dim rloc

rloc = "C:\LOCATION\result\"

Set wb = ThisWorkbook
Set temp = Workbooks.Open("C:\LOCATION\Template.xls")
' getting last row
lRow = wb.Sheets(1).Range("A1:A" & Rows.Count).End(xlDown).Row 'changed xlUp for xlDown
icounter = 0      

For i = 2 To lRow 'leaving out the header row

With wb.Sheets(1)
        Range("C2").Value = Cells(i, 1).Value
    If Cells(i, 1).Value = Cells(i, 1).Offset(1, 0).Value Then 'changed offset from (1,1)
        icounter = icounter + 1

    Else
        If icounter > 0 Then
            Range(cells(i,1):(cells(i,1).offset(-icounter,7)).Copy   'error
            wb.Sheet(8, 1).PasteSpecial xlValues
            Application.CutCopyMode = False
            Filename = Str(Cells(i, 1).Value) & "_" & Str(Cells(i, 3).Value) & ".xls"
            ChDir rloc
            temp.SaveAs Filename, xlWorkbookDefault
        Else
            Range(cells(i,1):cells(i,7)).Copy                         'error
            wb.Sheets(8, 1).PasteSpecial xlValues
            Application.CutCopyMode = False
            Filename = Str(Cells(i, 1).Value) & "_" & Str(Cells(i, 3).Value) & ".xls"
            ChDir rloc
            temp.SaveAs Filename, xlWorkbookDefault
        End If
    End If
End With
Next i
wb.Close savechanges:=False
temp.Close savechanges:=False
End Sub

我在与一个我不太明白的错误作斗争。一致：

Range(cells(i,1):(cells(i,1).offset(-icounter,7)).Copy

这是：

Range(cells(i,1):cells(i,7)).Copy 

有一个错误是这样说的：

Compile error:

Expected: list separator or )

我想不出怎么解决它。代码看起来很适合我

@编辑

使用新变量（“C”&i&“：”&“F”&i-icounter）绕过错误 经过一些小改动后，它成功了，谢谢：）

Range(cells(i,1):cells(i,7)).Copy 

Compile error:

Expected: list separator or )