把excel一个工作簿中多个工作表的特定位置合并在一个表中

• 步骤1

  利用FileDialog对象让用户指定待合并文件的路径，然后调用DIR方法将该路径下所有文件名包括路径写入数组中。

  利用InputBox设计一个输入框，让用户指定标题行数量。利用For…Next循环将工作簿逐个打开，在循环中再套一层循环，逐一将工作表中的已用区域UsedRange除标题行外的所有数据复制到合并工作表C列第一个空单元格，直到最后一个工作簿的最后一个工作表。

  所有数据粘贴的其实位置都从C列第一个空单元格开始，其中A列和B列则分别用于存放数据所对应的工作簿名与工作表名。工作簿名直接通过DIR从数组中获取，工作表名则通过循环体中的“Sheets(i).Name”语句获取

  新建一个工作表，用于存放数据，然后按Alt+F11组合键打开VBE窗口，选择菜单“插入”——“模块”，并输入以下代码：

  Sub 多工作簿合并()

  Dim file() As String, FileStr As String, n As Integer, PathStr As String, HeadRows As Byte, Namess As String, ActiveWb As Workbook, Cell As Range

  With Application.FileDialog(msoFileDialogFilePicker)

  If .Show Then

  PathStr = .SelectedItems(1)

  Else

  Exit Sub

  End If

  End With

  On Error Resume Next

  FileStr = Dir(PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & "*.xls*")

  While Len(FileStr) > 0

  n = n + 1

  ReDim Preserve file(1 To n)

  file(n) = PathStr & IIf(Right(PathStr, 1) = "\", "", "\") & FileStr

  FileStr = Dir()

  Wend

  If n = 0 Then MsgBox "没发现excel文件": Exit Sub

  Set ActiveWb = ActiveWorkbook

  HeadRows = Application.InputBox("请确认待合并工作簿的标题行数，改行将产生在合并工作表中作为新的标题行： ", "标题行", 1, , , , , 1)

  If HeadRows < 1 Then Exit Sub

  Range("A" & HeadRows & ":B" & HeadRows) = Array("工作簿名", "工作表名")

  Application.Calculation = xlCalculationManual

  Application.Calculation = xlCalculationManual

  For k = 1 To n

  Namess = Dir(file(k))

  Workbooks.Open Filename:=file(k)

  ActiveWb.Activate

  If k = 1 Then Intersect(Wokbooks(Namess).Sheets(1).UsedRange, Workbooks(Namess).Sheets(1).Rows("1:" & HeadRows)).Copy Cells(1, 3)

  For i = 1 To Workbooks(Namess).Sheets.Count

  With Workbooks(Namess).Sheets(i).WsedRange

  If Not IsEmpty(Workbooks(Namess).Sheets(i).UsedRange) Then

  If .Rows.Count <= HeadRows Then GoTo liness

  Set Cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 3)

  Intersect(.Offset(HeadRow, 0), .Cells).Copy Cell

  Cell.Resize(.Rows.Count - HeadRows, .Columns.Count) = Intersect(.Offset(HeadRow, 0), .Cells).Value

  Cell.Offset(0, -2) = Resize(.Rows.Count - HeadRows, 1).Merge

  Cell.Offset(0, -2) = Namess

  Cell.Offset(0, -1).Resize(.Rows.Count - HeadRows, 1).Merge

  Cell.Offset(0, -1) = Workbooks(Namess).Sheets(i).Name

  End If

  End With

  lines:

  Next i

  Workbooks(Namess).Close False

  Next k

  Application.ScreenUpdating = True

  Application.Calculation = xlCalculationAutomatic

  End Sub

  光标置于代码中任意位置，并按F5键执行，将弹出“浏览”对话框。在对话框中选择目标文件夹后单击“确定”按钮。不需要打开文件，选择文件夹后直接单击“确定”按钮即可。

  

• 2步骤2

  在弹出的“标题行”对话框中输入1，表示待合并工作簿中工作表的标题只有一行。

• 3步骤3

  单击“确定”按钮，瞬间完成文件夹中所有工作簿数据的合并，下图是合并后的效果，A、B列用于存放工作簿名、工作表名，其他区域则是用户的数据

网页链接