VBA学习心得3

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