VBA-使用DIR函数多文件合并

如何将对象赋值给变量

Sub test()
Dim sht As Worksheet
sht = Sheets.Add  '这里会报错的
Set sht = Sheets.Add ‘将对象赋值给变量 需要加上set
sht.Name = "4月"
End Sub

例子：创建表 以sheet1的单元格内容为名字

Sub test()
Dim sht As Worksheet
Dim i As Integer
For i = 2 To 5
    Set sht = Sheets.Add
    sht.Name = Sheet1.Range("a" & i)
Next
End Sub

dir函数

　　1）判断有无此文件    dir里支持通配符

Sub test()
Dim i As Integer
For i = 1 To 5
    If Dir("a:\data\" & Sheet1.Range("a" & i) & ".xls*") = "" Then     #支持通配符
        Sheet1.Range("b" & i) = "无此文件"
    Else
        Sheet1.Range("b" & i) = "有文件"
    End If

Next
End Sub

　　2）dir的使用说明，在文件data里有多个苏州文档 如 苏州.xlsx 、苏州.xls  

Sub ss()
Range("a1") = Dir("d:\data\苏州.xls*") #返回苏州     Dir("d:\data\*.*")遍历所有文件
Range("a1") = Dir　　#返回苏州
Range("a1") = Dir　　#返回空
Range("a1") = Dir　　#报错
End Sub

　　3）遍历所有文件名

Sub test1()
Dim str As String
str = Dir("d:\data\*.xls*")
For i = 1 To 100
    Range("a" & i) = str
    str = Dir
    If str = "" Then
        Exit For
    End If
Next
End Sub

　　4）壳子，对固定的文件夹内的数据打开  再关闭

Sub test1()
Dim str As String
Dim wb As Workbook
str = Dir("d:\data\*.xls*")
For i = 1 To 100
    Set wb = Workbooks.Open("d:\data\" & str)
    
    
    
    
    wb.Close
    str = Dir
    If str = "" Then
        Exit For
    End If
Next
End Sub

 　　5）合并多文件

Sub wjhb()
Dim str As String
Dim wb As Workbook
str = Dir("d:\data\*.xls*")
For i = 1 To 100
    Set wb = Workbooks.Open("d:\data\" & str)
    wb.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Split(wb.Name, ".")(0)
    wb.Close
    str = Dir
    If str = "" Then
        Exit For
    End If
    
Next
End Sub

　　6）最终版 -无敌了

Sub wjhb()
Dim str As String
Dim wb As Workbook
Dim sht As Worksheet
str = Dir("d:\data\*.xls*")
For i = 1 To 100
    Set wb = Workbooks.Open("d:\data\" & str)
    For Each sht In wb.Sheets
        sht.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Split(wb.Name, ".")(0) & sht.Name
    Next
    wb.Close
    str = Dir
    If str = "" Then
        Exit For
    End If
    
Next
End Sub

 find函数的用法，通过find可以快速查找到要找的数据（通过下面的方法可以避免find找不到报错的问题）

Sub test()
Dim rng As Range
Set rng = Range("d:d").Find(Range("l3")) '这里如果找不到就不会再报错，没找到那么rng就是空的
    If rng Is Nothing Then  '单元格不能为空，它是个对象 只能为nothing
        MsgBox "找不到"
    Else
        Range("m3") = rng.Offset(0, 3)
    End If
    
End Sub

　　优化

Sub test()
Dim rng As Range
Set rng = Range("d:d").Find(Range("l3"))
    If Not rng Is Nothing Then
        Range("m3") = rng.Offset(0, 3)
    End If
End Sub

　　拆分多表 具有通用性

Sub chaifenshuju()


Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer '这个说的是一共多少行
Dim l As Integer
Dim sht0 As Worksheet



Set sht0 = ActiveSheet

l = InputBox("请输入你要按哪列分")


'删除无意义的表
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> sht0.Name Then
            sht1.Delete
        End If
    Next
End If
Application.DisplayAlerts = True '这个地方上课的时候我没改成true，请大家注意一下





irow = sht0.Range("a65536").End(xlUp).Row
'拆分表
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = sht0.Cells(i, l) Then
            k = 1
        End If
    Next
    
    
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sht0.Cells(i, l)
    End If

Next
'拷贝数据

For j = 2 To Sheets.Count
    sht0.Range("a1:z" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    sht0.Range("a1:z" & irow).Copy Sheets(j).Range("a1")
Next

sht0.Range("a1:z" & irow).AutoFilter

sht0.Select

MsgBox "已处理完毕，牛逼不"

End Sub