常用代码

VBA常用代码（表格合并）

日常工作中，每天都要用到EXCEL，不可避免地会遇到表格的合并、拆分等操作，数量少的时候还好办，一旦数量多起来，就显得很繁琐。
以下一些代码就是在不同场景下进行表格合并，可以根据实际情况进行适当调整。
以下代码还有一个好处也非常实用，如果你注意到壳子的字样，就意味着在壳子中间的部分，可以自由发挥，即做一些你想对EXCEL做的操作，这样一来，程序的灵活性就大了些，可调整的余地也更大了。
建议仔细看看这些代码，然后上手实操，感受一下：
代码1

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
'使用场景：将指定路径下的文件合并到一张汇总表
Sub combine ()
Dim str As String
Dim wb As Workbook
Dim i, j As Integer   
'i用来计算数据源的表有多少行  
'j用来计算汇总表目前有多少行数据，例如有10行，就从11行开始复制数据
str = Dir("d:\data\*.xls*")
For i = 1 To 100    
    Set wb = Workbooks.Open("d:\data\" & str)
'#####################上面是壳子#################################        
    i = wb.Sheets(1).Range("a65535").End(xlUp).Row    
    j = ThisWorkbook.Sheets("数据").Range("a65535").End(xlUp).Row  
    wb.Sheets(1).Range("a2:g" & i).Copy ThisWorkbook.Sheets("数据").Range("a" & j + 1)
'数据源的数据复制到汇总表里面    
    ThisWorkbook.Sheets("数据").Range("h" & j + 1).Resize(i - 1, 1) = Split(wb.Name, ".")(0)  
'从汇总表复制数据那一行开始，用resize往下选i-1行，里面全写上城市名        
'#############################下面是壳子######################################    
    wb.Close    
    str = Dir    
    If str = "" Then        
        Exit For    
    End If
Next
End Sub

代码2

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'使用场景：选取路径下的文件合并到一张汇总表
Sub combine1 ()
Dim str
Dim wb, wb1 As Workbook
Dim i, j As Integer   'i用来计算数据源的表有多少行  j用来计算汇总表目前有多少行数据，例如有10行，就从11行开始复制数据'
Set sht = ActiveSheet'汇总到当前表
Set wb1 = Workbooks.Add '新建一个文件，并将数据汇总到这个文件的第一张表中
Set sht = wb1.Sheets(1)
str = Application.GetOpenFilename(",*.*", , , , True)
For i = LBound(str) To UBound(str)    
    Set wb = Workbooks.Open(str(i))    
'############################上面是壳子#######################################        
    i = wb.Sheets(1).Range("a65535").End(xlUp).Row 'i用来计算数据源的表有多少行    
    j = sht.Range("a" & Rows.Count).End(xlUp).Row 'j用来计算汇总表目前有多少行数据        
    wb.Sheets(1).Range("a2:g" & i).Copy sht.Range("a" & j + 1)  '数据源的数据复制到汇总表里面  
    sht.Range("h" & j + 1).Resize(i - 1, 1) = Split(wb.Name, ".")(0)  '从汇总表复制数据那一行开始，用resize往下选i-1行，里面全写上wb名字        
'#############################下面是壳子######################################    
    wb.Close
Next
End Sub

代码3

1
2
3
4
5
6
7
8
9
10
11
12
13
'使用场景：同一个工作簿的不同工作表数据汇总到一张新建的表中并将表改名
Sub combine ()
Dim sht As Worksheet
Dim i, j, k As Integer
Sheets.Add
Set sht = ActiveSheet
For i = 2 To Sheets.Count
j = Sheets(i).Range("a" & Rows.Count).End(xlUp).Row
k = sht.Range("a" & Rows.Count).End(xlUp).Row
Sheets(i).Range("a2:z" & j).Copy sht.Range("a" & k + 1)
Next
Sheets(2).Range("a1").EntireRow.Copy sht.Range("a1")sht.Name = "汇总表"
End Sub

代码4

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
'使用场景：选中路径下的文件提取到同一张工作簿的不同表中
Sub getsht ()
Dim str()
Dim i As Integer
Dim wb, wb1 As Workbook
Dim sht As Worksheet
Range("a:z").ClearComments
On Error Resume Next '这一句加上以后防止点了取消发生的错误
Set wb1 = ActiveWorkbookSet sht1 = ActiveSheet
On Error Resume Next
str = Application.GetOpenFilename("Excel数据文件,*.xls*", , , , True)    
For i = LBound(str) To UBound(str)        
Set wb = Workbooks.Open(str(i))
'#######################上面是壳子######################################        
For Each sht In wb.Sheets            
sht.Copy after:=wb1.Sheets(wb1.Sheets.Count)            
wb1.Sheets(wb1.Sheets.Count).Name = Split(wb.Name, ".")(0) & sht.Name        
Next
'########################下面是壳子####################################      
wb.Close    
Next
End Sub

代码5

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
'使用场景：将不同表中指定单元格内容提取出来，并填写进另外一个新建的工作簿中的工作表
Sub test () 
Dim arr()
Dim wb, wb1 As Workbook
Dim i, j As Integer
Dim rng1 As Range
Dim SHT As Worksheet
Set wb1 = Workbooks.Add '新建一个文件，并将数据汇总到这个文件的第一张表中
Set SHT = wb1.Sheets(1)
arr = Application.GetOpenFilename(",*.xls*", , "请选择", , True)
If arr(1) <> "False" Then
    For i = LBound(arr) To UBound(arr)
        Set wb = Workbooks.Open(arr(i))
        j = 0
        j = SHT.Range("a" & Rows.Count).End(xlUp).Row
        SHT.Range("a" & j + 1) = wb.Sheets("报告页").Range("i20"
        wb.Save
        wb.Close
    Next
End If
End Sub