VBA 查找文件夹下Excel文件指定行并合为新表，且要求新表第一列为数据源表名称

Question

目前会的vba非常的少，所以直接求代码了........领导让整理我简直要死了。。。。

我想要文件夹下的Excel格式都是一样的，现在需要从里面筛选出第一列为指定字段的行，并将该行复制到新建Excel中，且需要将数据来源的文件名写入新建Excel sheet页的第一列，如图。

文件夹下的文件：

文件打开效果（以茅台为例，在不同日期可见该字段的行数是随机的）

最后需要达到的效果如图所示（只做了部分例子，实际需要将文件夹中的文件全部遍历）

由于存在其他文件夹，不同文件夹下的表头个数可能并不相同（图片只是其中一种表），请大佬注意这一部分的编写，谢谢啦~~！

Answer 1

这样？

 

Sub CopyRow()

 code = InputBox("请输入代码：", "提示", "600519")
 row = 1
  
  writeheader = True
  
  path = "F:\vba\文件数据行提取\excels\" ''''''''''注意改这里为你存储Excel文件的路径
  cellnum = 0
  
  f = Dir(path & "*.*") '找目录中的文件
  Do Until f = ""
     filepath = path & f 'Excel文件路径，注意f只是文件名
     Workbooks.Open Filename:=filepath, ReadOnly:=True
     
     If writeheader Then '写入表头
       cellnum = Sheets(1).Cells(Rows.Count, 1).End(xlUp).row + 1 '列数
       For i = 1 To cellnum
         ThisWorkbook.Sheets(1).Cells(row, i + 1) = Sheets(1).Cells(row, i)
       Next
       writeheader = False
       row = row + 1
     End If
     
     Set c = Sheets(1).Range("A2:A65535").Find(code)

 
     If Not c Is Nothing Then
       ThisWorkbook.Sheets(1).Cells(row, 1) = f
       For i = 1 To cellnum
          ThisWorkbook.Sheets(1).Cells(row, i + 1) = Sheets(1).Cells(c.row, i)
       Next
       row = row + 1
     End If
   
     
     Workbooks(2).Close SaveChanges:=False '关闭被打开的Excel
     
    
     
     f = Dir '继续遍历下一个文件
   Loop


End Sub