代码求指点，如何查找所有子文件夹内指定名称文件及整合其数据

残碑日月

文件形式为文件夹A内包含BCDE等若干子文件夹，子文件夹内都包含一个名为1.xlsx的文件，该文件内有两行数据。

需求为将所有1.xlsx的该两行数据依次整合到一个sheet里统计。

我的操作逻辑是
1.找到A文件夹内第一个B文件夹，找到B文件夹内1.xlsx文件并打开
2.复制其前两行到我的sheet1的1,2行。然后关闭1.xlsx文件（我用的Workbooks.Close会报错，还没研究为什么）
3.寻找下一个C文件夹的1.xlsx文件，打开，此时需要复制到sheet1的3.4行
现在代码上存在第一个问题复制range和我想象中不太一样，虽然只选了A1但实际上把A1相连的所有数据都copy了。但这样倒也能实现要求所以还行
但第二个文件开始的复制想换行就不行了，因为我不是很熟悉fso所以定义的变量会在代码中被重置。实际上导致我没法利用循环去实现复制数据的位置改变

核心问题就是
1，如何实现随着过程依次下移我的粘贴区域
2，也请顺便解答如何实现两个workbook之间的指定区域（比如把一个文件的A1:B10到另一个文件的A1:B10）复制？
代码截图和文档都有附件，请大佬指点

闻启学

1. Sub ykcbf()   '//2024.8.22
   
2.    
   
3.     Application.ScreenUpdating = False
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .Title = "请选择文件夹"
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = -1 Then
   
8.             p = .SelectedItems(1) & ""
   
9.         End If
   
10.     End With
    
11.     getfds p
    
12. End Sub
    
13. 
    
14. Sub getfds(p)
    
15.     Set fso = CreateObject("Scripting.FileSystemObject")
    
16.     Dim fileName As String
    
17.     Dim icell As Integer
    
18.     Dim mywb As Workbook
    
19.    
    
20.     icell = 1
    
21.     'Nowbookname = Mid(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "") + 1)
    
22.     For Each fd In fso.GetFolder(p).SubFolders
    
23.         For Each f In fso.GetFolder(fd).Files
    
24.             fileName = Mid(f, InStrRev(f, "") + 1)
    
25.             'fileName = Left(fileName, InStrRev(fileName, ".") - 1)
    
26.             If fileName = "1.xlsx" Then
    
27.                 Set mywb = Workbooks.Open(f)
    
28.                 'Workbooks("1.xlsx").Worksheets("Sheet1").Range("2:2").CurrentRegion.Copy Workbooks("代码所在工作簿.xlsm").Worksheets("Sheet1").Range("icell:icell")
    
29.              '//   mywb.Worksheets("Sheet1").Range("A1").CurrentRegion.Copy ThisWorkbook.Worksheets("Sheet1").Range("A" & icell)
    
30.              icell = ThisWorkbook.Worksheets("Sheet1").Range("A" & Rows.Count).End(3).Row + 1
    
31.              mywb.Worksheets("Sheet1").Range("A1").Range("A1:G2").Copy ThisWorkbook.Worksheets("Sheet1").Range("A" & icell)
    
32.               '//  icell = icell + 2
    
33.                 mywb.Close
    
34.                 ' Workbooks("代码所在工作簿.xlsm").Worksheets("Sheet1").Range("A2").CurrentRegion.Copy Workbooks("代码所在工作簿.xlsm").Worksheets("Sheet2").Range("A2")
    
35.                 'Workbooks("代码所在工作簿.xlsm").Worksheets("Sheet1").Range("A1").CurrentRegion.Copy f.Worksheets("Sheet1").Range("D1")
    
36.                 'Workbooks.Close f
    
37.             End If
    
38.         Next
    
39.         getfds fd.Path
    
40.     Next fd
    
41.     Set fso = Nothing
    
42. End Sub
    

复制代码

闻启学

1，如何实现随着过程依次下移我的粘贴区域
2，也请顺便解答如何实现两个workbook之间的指定区域（比如把一个文件的A1:B10到另一个文件的A1:B10）复制？
代码截图和文档都有附件，请大佬指点



见到代码 想吐血！

1 , 打开Excel文件后无指定工作薄的对象  一般用指定工作簿对象  ，工作簿打开后 一定要有关闭动作 否则肯定出错
Set mywb = Workbooks.Open(f)  
mywb.close

2   在循环语句里面 循环获得 工作表的最后一行    这样可以现随着过程依次下移我的粘贴区域

icell = ThisWorkbook.Worksheets("Sheet1").Range("A" & Rows.Count).End(3).Row + 1
  mywb.Worksheets("Sheet1").Range("A1").Range("A1:G2").Copy ThisWorkbook.Worksheets("Sheet1").Range("A" & icell)


3， 将语句改为这个
       mywb.Worksheets("Sheet1").Range("A1").Range(“单元区域”).Copy ThisWorkbook.Worksheets("Sheet1").Range("A" & icell)

残碑日月

闻启学 发表于 2024-11-20 21:12
1，如何实现随着过程依次下移我的粘贴区域
2，也请顺便解答如何实现两个workbook之间的指定区域（比如把一 ...

感谢指点，尝试了一下可以跑了