weixin_52155901
ArcherNya
采纳率50%
2021-05-16 19:59 阅读 37

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

50

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

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

文件夹下的文件:

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

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

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

  • 点赞
  • 写回答
  • 关注问题
  • 收藏
  • 复制链接分享

2条回答 默认 最新

  • 已采纳
    showbo GoCityPass新加坡曼谷通票 2021-05-16 22:01

    这样?

     

    
    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
    
    点赞 1 评论 复制链接分享
  • weixin_43742828 白墨MO 2021-05-16 21:18

    VBA我不会,我倒是可以用RPA给你做出来,可以私聊我发详细的需求和表格文件

    点赞 评论 复制链接分享

相关推荐