VBA学习心得4

作者: Walteverything | 来源:发表于2022-03-22 10:44 被阅读0次

干%…………￥#……&*……&*@#万门跑路了，我最近看的课还没看完啊真狗

V1.0 版

Option Explicit

'“Option Explicit”的作用为：声明所有变量都需要先定义才能使用，否则程序在使用了未经定义的变量时就会报错，

'这样，可以避免变量因名称拼写等错误带来的结果错误，并且“Option Explicit”可以加快程序的运行速度，它节省了在程序运行时动态分配变量存储空间的时间

Sub 导入文件1_复制第一张表() '合并多工作簿中指定工作表

On Error Resume Next '忽略报警错误，不加此句，for each循环，打开选择文件时，不选文件会报错。

Dim allFile, file, arr As Variant

Dim wb, twb As Workbook

Dim ws, tws, tws2 As Worksheet

Dim row, col, row2, col2, wb_rows, i, j As Integer

Dim FirstRowNum, FirstColNum, TempRowNum, TempColNum As Integer

Dim wb_name As String

Dim title, titles As Range

Dim a, b

Dim dicTemp As Object

Dim strExists As String

Dim datas As Object

Dim name As Range

Dim xingming As Range

'禁用屏幕更新和显示警告以加快宏代码的速度

Application.ScreenUpdating = False '

Application.DisplayAlerts = False

'Workbooks("TEST.xlsx").Worksheets("Sheet1").Activate

Set twb = ThisWorkbook '设置当前工作簿

Set tws = twb.Sheets(1) '设置当前工作簿的第一张工作表

Set tws2 = twb.Sheets(2) '设置当前工作簿的第二张工作表

'为了便于比对，每次导入文件前将第二张表清空

tws2.Cells.Clear '将第二张工作表清空

'导入文件

allFile = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _

title:="Excel选择", MultiSelect:=True)

For Each file In allFile

If file <> False Then

Set wb = Workbooks.Open(file) '循环打开选定的文件

Set ws = wb.Sheets(1) '打开选定的第一张工作表

'全部复制到第二张表中

col2 = tws2.UsedRange.SpecialCells(xlCellTypeLastCell).column '第二张工作表中所有已使用的单元格区域列

row2 = tws2.UsedRange.SpecialCells(xlCellTypeLastCell).row '第二张工作表中所有已使用的单元格区域行

If col2 = 1 And row2 = 1 And tws2.Cells(1, 1) = "" Then

ws.UsedRange.Copy tws2.Cells(1, 1)

Else

ws.UsedRange.Copy tws2.Cells(row2 + 1, 1)

End If

'选择性复制到第一张表

col = tws.UsedRange.SpecialCells(xlCellTypeLastCell).column '第一张工作表中所有已使用的单元格区域列

row = tws.UsedRange.SpecialCells(xlCellTypeLastCell).row '第一张工作表中所有已使用的单元格区域行

'ws.Cells.Find("姓名").Select

Set name = ws.Cells.Find("姓名") '查找姓名所在单元格

'name.Select

'MsgBox name.Address

FirstRowNum = name.row '查看姓名所在单元格在第几行，首行

FirstColNum = name.column

'计算导入表的信息行数_TempRowNum，肯定大于1

TempRowNum = Range(name, name.End(xlDown)).Rows.Count - 1

TempColNum = Range(name, name.End(xlToRight)).Columns.Count

'存为数组arr

Set arr = Range(Cells(FirstRowNum, FirstColNum), Cells(FirstRowNum + TempRowNum, FirstColNum + TempColNum - 1))

'Rng.Parent.UsedRange '选中当前所使用的区域

'Rows(name.Row).Select '选中当前行

Set titles = Intersect(arr, Rows(name.row)) 'intersect语句求交集。

'titles.Select

For Each title In titles

'a = title.row

'b = title.column

If title = "姓名" Then

For i = 1 To TempRowNum