求助 老师帮忙看看代码

chenkj0802

Sub 合同同一文件夹下的所有表()
    dim r as long
    r = 1
    Application.ScreenUpdating = False
    Dim filename As String, wb As Workbook, sht As Worksheet, erow As Long, fn As String, arr As Variant, flag As Integer
    filename = Dir(ThisWorkbook.Path & "\*.xls")  
    flag = 1
    Do While filename <> ""
        If filename <> ThisWorkbook.Name Then   
            If flag = 1 Then
            erow = 1
            Else
            erow = Range("A1").CurrentRegion.Rows.Count + 1   
            End If
        fn = ThisWorkbook.Path & "\" & filename
        Set wb = GetObject(fn)      
        Set sht = wb.Worksheets(1)   
            If flag = 1 Then      
            arr = sht.Range(sht.Cells(r, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 9))   
            Else
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 9))
            End If
        Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr   'UBound(arr, 1)计算出行数，UBound(arr, 2)计算出列数
        wb.Close False   
        End If
        filename = Dir  
        flag = 2
    Loop
    Application.ScreenUpdating = True

End Sub


这个代码为了合并当前目录下所有的excel文档，但是有个问题是合并完了以后第一列的标题行没有了，在flag=1的时候，即第一个文档时候保留了标题的，为什么后面不见了？有老师解答一下吗？需要怎么改能保留标题行？

仰望兴叹

Cells(r, "A")的用法是不是有问题啊，改成Cells(r, 1)试试?

microyip

仰望兴叹 发表于 2018-8-13 09:54
Cells(r, "A")的用法是不是有问题啊，改成Cells(r, 1)试试?

纯粹说你问的问题，这个写法，没问题哦

microyip

连附件都没有一个，是不是有点……

lsc900707

建议上传你的附件。

仰望兴叹

microyip 发表于 2018-8-13 10:07
纯粹说你问的问题，这个写法，没问题哦

惭愧... 小弟头一次知道还有这种操作，多谢指教，学习啦！

仰望兴叹

我用自己的文件测试了，没出现你说的这种问题啊。