跨文件数据汇总到总表

天真无鞋

那位老师能否在改一下此代码，如果获取的文件夹没有数据都情况下报错

baofa2

if n then  加上黄色的那一句

天真无鞋

baofa2 发表于 2024-5-23 11:59
if n then  加上黄色的那一句

谢谢老师

Qs18

Sub test()
Application.ScreenUpdating = False
Dim wb As Workbook, xb As Workbook, na, rw1, rw2, t1, t2, arr, k
Set wb = ThisWorkbook
k = 3
na = wb.Name
rw1 = wb.Sheets("sheet1").[a1].Value
rw2 = wb.Sheets("sheet1").[a2].Value
t1 = wb.Sheets("sheet1").[b1].Value
t2 = wb.Sheets("sheet1").[b2].Value
Dim pt As String
Set FSO对象 = CreateObject("Scripting.FileSystemObject")
pt = ThisWorkbook.Path & "\"   '相对路径及文件夹名称
Set 文件夹 = FSO对象.GetFolder(pt)
For Each i In 文件夹.Files '循环文件下的每一个文件
    If VBA.InStr(i, na) < 1 Then
        文件名 = FSO对象.GetBaseName(i)
        Set xb = Workbooks.Open(i, 0)
        
        arr = xb.Sheets(1).UsedRange.Value
        For j = 1 To UBound(arr, 2)
            If arr(rw1, j) = t1 Then
                brr = Split(Cells(rw1, j).Address, "$")
                k = k + 1
                wb.Sheets(1).Cells(k, 1) = 文件名
                wb.Sheets(1).Cells(k, 2) = brr(1)
            End If
            
            Next
                For j = 1 To UBound(arr, 2)
                If arr(rw2, j) = t2 Then
                brr = Split(Cells(rw1, j).Address, "$")
                k = k + 1
                wb.Sheets(1).Cells(k, 1) = 文件名
                wb.Sheets(1).Cells(k, 2) = brr(1)
            End If
        Next
        xb.Close
    End If
Next
Set xb = Nothing
Set wb = Nothing
Application.Selection = True
MsgBox "完毕！"
End Sub

Qs18

试试。。。。。

Qs18

试一下。。。。