老师帮忙改下代码

chenkj0802

之前提了问题，没上传附件，这次补发一个附件，老师帮忙看看。在合并同一目录下所有excel文档后，如何保留第一行的标题。为什么我合并后第一行不见了。代码看看好像也没问题，麻烦老师看看，谢谢啦

microyip

1. Sub 合同同一文件夹下的所有表()
   
2.     Dim FileName As String, wb As Workbook, sht As Worksheet, erow As Long, fn As String, arr As Variant
   
3.     Dim r As Long, c As Long, bNotNeedTitle As Boolean
   
4.     Application.ScreenUpdating = False
   
5.     erow = 1
   
6.     [A:C].ClearContents
   
7.     FileName = Dir(ThisWorkbook.Path & "\*.xls")
   
8.     Do While FileName <> ""
   
9.         If FileName <> ThisWorkbook.Name Then
   
10.             fn = ThisWorkbook.Path & "" & FileName
    
11.             Set wb = GetObject(fn)
    
12.             With wb.Worksheets(1).UsedRange.Resize(, 3)
    
13.                 arr = .Offset(-1 * bNotNeedTitle).Resize(.Rows.Count + 1 * bNotNeedTitle).Value
    
14.             End With
    
15.             wb.Close False
    
16.             Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
17.             erow = erow + UBound(arr)
    
18.             bNotNeedTitle = True
    
19.         End If
    
20.         FileName = Dir
    
21.     Loop
    
22.     Application.ScreenUpdating = True
    
23. End Sub
    

复制代码

microyip

附上附件以供参考

鄂龙蒙

1. Sub 合同同一文件夹下的所有表()
   
2.     Dim r As Long, c As Long
   
3.     Dim filename As String, wb As Workbook, sht As Worksheet, erow As Long, fn As String, arr As Variant, flag As Integer
   
4.     r = 1: c = 3
   
5.     Range(Cells(r, "A"), Cells(65536, c)).ClearContents
   
6.     Application.ScreenUpdating = False
   
7.     filename = Dir(ThisWorkbook.Path & "\*.xls")
   
8.     flag = 1
   
9.     Do While filename <> ""
   
10.         If filename <> ThisWorkbook.Name Then
    
11.             fn = ThisWorkbook.Path & "" & filename
    
12.             Set wb = GetObject(fn)
    
13.             Set sht = wb.Worksheets(1)
    
14.             If flag = 1 Then
    
15.                 erow = 1
    
16.                 arr = sht.Range(sht.Cells(r, "A"), sht.Cells(65536, c).End(xlUp))
    
17.             Else
    
18.                 erow = Range("A1").CurrentRegion.Rows.Count + 1
    
19.                 arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, c).End(xlUp))
    
20.             End If
    
21.             Cells(erow, "A").Resize(UBound(arr, 1), c) = arr
    
22.             wb.Close False
    
23.             flag = 2
    
24.         End If
    
25.         filename = Dir
    
26.     Loop
    
27.     Application.ScreenUpdating = True
    
28. End Sub

复制代码

chenkj0802

microyip 发表于 2018-8-17 08:21
附上附件以供参考

非常nice，谢谢老师

chenkj0802

鄂龙蒙 发表于 2018-8-17 08:37

谢谢老师 非常感谢