V0.9 版
Option Explicit
Sub 导入文件_全部复制到表2() '合并多工作簿中指定工作表
On Error Resume Next '忽略报警错误，不加此句，for each循环，打开选择文件时，不选文件会报错。
Dim x, y, z As Variant
Dim wb, twb As Workbook
Dim ws, tws As Worksheet
Dim row, column As Integer
Application.ScreenUpdating = False '禁用屏幕更新可以加快宏代码的速度。
Application.DisplayAlerts = False '禁用显示警告
x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _
title:="Excel选择", MultiSelect:=True)
Set twb = ThisWorkbook '选择当前工作簿
Set tws = twb.Sheets(2) '选择当前工作簿的第一张工作表
For Each y In x
If y <> False Then
Set wb = Workbooks.Open(y) '循环打开选定的文件
Set ws = wb.Sheets(1) '打开选定的第一张工作表
column = tws.UsedRange.SpecialCells(xlCellTypeLastCell).column '当前工作表中所有已使用的单元格区域列
row = tws.UsedRange.SpecialCells(xlCellTypeLastCell).row '当前工作表中所有已使用的单元格区域行
If column = 1 And row = 1 And tws.Cells(1, 1) = "" Then
ws.UsedRange.Copy tws.Cells(1, 1)
Else
ws.UsedRange.Copy tws.Cells(row + 1, 1)
End If
wb.Close
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub 导入文件_部分复制到表1() '合并多工作簿中指定工作表
On Error Resume Next '忽略报警错误，不加此句，for each循环，打开选择文件时，不选文件会报错。
Dim x, y, z As Variant
Dim wb, twb As Workbook
Dim ws, tws As Worksheet
Dim row, col, wb_rows As Integer
Dim wb_name As String
Dim i As Integer
Application.ScreenUpdating = False '禁用屏幕更新可以加快宏代码的速度。
Application.DisplayAlerts = False '禁用显示警告
x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _
title:="Excel选择", MultiSelect:=True)
Set twb = ThisWorkbook '选择当前工作簿
Set tws = twb.Sheets(1) '选择当前工作簿的第一张工作表
For Each y In x
If y <> False Then
Set wb = Workbooks.Open(y) '循环打开选定的文件
Set ws = wb.Sheets(1) '指定合并到的工作表
col = tws.UsedRange.SpecialCells(xlCellTypeLastCell).column '当前工作表中所有已使用的单元格区域列
row = tws.UsedRange.SpecialCells(xlCellTypeLastCell).row '当前工作表中所有已使用的单元格区域行
ws.Cells.Find("*姓*名*").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
wb_rows = Selection.Rows.Count
If wb_rows = 0 Then
ws.Cells.Find("*姓*名*").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 2)
Else
Selection.Copy tws.Cells(row + 1, 2)
End If
ws.Cells.Find("*身份*").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If wb_rows = 0 Then
ws.Cells.Find("*身份*").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 3)
Else
Selection.Copy tws.Cells(row + 1, 3)
End If
ws.Cells.Find("*银行卡*").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If wb_rows = 0 Then
ws.Cells.Find("*银行卡*").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 4)
Else
Selection.Copy tws.Cells(row + 1, 4)
End If
ws.Cells.Find("*开户*").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If wb_rows = 0 Then
ws.Cells.Find("*开户*").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 5)
Else
Selection.Copy tws.Cells(row + 1, 5)
End If
ws.Cells.Find("应*").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If wb_rows = 0 Then
ws.Cells.Find("应*").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 6)
Else
Selection.Copy tws.Cells(row + 1, 6)
End If
ws.Cells.Find("个税").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If wb_rows = 0 Then
ws.Cells.Find("个税").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 7)
Else
Selection.Copy tws.Cells(row + 1, 7)
End If
ws.Cells.Find("实*").Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If wb_rows = 0 Then
ws.Cells.Find("实*").Offset(1, 0).Select
Selection.Copy tws.Cells(row + 1, 8)
Else
Selection.Copy tws.Cells(row + 1, 8)
End If
'备注
wb_name = Left(wb.name, Len(wb.name) - 5)
If wb_rows = 0 Then
tws.Cells(row + 1, 9) = wb_name
Else
For i = row + 1 To row + wb_rows
tws.Cells(i, 9) = wb_name
Next
End If
wb.Close
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Dim Rng As Range
'Set Rng = Intersect(Rng.Parent.UsedRange, Rng) 'intersect语句求交集。
Sub mergeonexls() '合并多工作簿中指定工作表
On Error Resume Next
Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet
Dim t As Workbook, ts As Worksheet, l As Integer, h As Long
Application.ScreenUpdating = False '禁用屏幕更新可以加快宏代码的速度。
Application.DisplayAlerts = False '禁用显示警告
x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _
title:="Excel选择", MultiSelect:=True)
Set t = ThisWorkbook
Set ts = t.Sheets(1) '指定合并到的工作表，这里是第一张工作表
l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).column
For Each x1 In x
If x1 <> False Then
Set w = Workbooks.Open(x1)
Set wsh = w.Sheets(1) '指定所需合并工作表，这里是第一张工作表
h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).row
If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then
wsh.UsedRange.Copy ts.Cells(1, 1)
Else
wsh.UsedRange.Copy ts.Cells(h + 1, 1)
End If
w.Close
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
