1234

ExcelHome技术论坛

用户名  找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

帖子
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 141|回复: 8

[求助] 求助一个两个文件夹内的复制粘贴的问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2025-1-20 18:02 | 显示全部楼层 |阅读模式
把2025文件夹中的三个EXCEL文件的每个表里面的 L 到 T 列的内容复制到2026文件夹中三个对应的文件中的 L 到 T 列,按说想着不复杂,但不熟悉这些操作,请高手指导一个VBA文件,设置一个按钮,点一下就能执行完成。

示例.png

内容.rar (528.92 KB, 下载次数: 4)

TA的精华主题

TA的得分主题

发表于 2025-1-20 18:12 | 显示全部楼层
文件无法打开,不知道是哪里的原因

TA的精华主题

TA的得分主题

发表于 2025-1-20 18:47 | 显示全部楼层
因为不能同时打开二个同名文件,所以,多写了一些代码。

内容.zip

1.02 MB, 下载次数: 8

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2025-1-20 18:48 | 显示全部楼层
同名文件数据复制

  1. Sub ykcbf()    '//2025.1.20
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     Set fso = CreateObject("Scripting.FileSystemObject")
  5.     p = ThisWorkbook.Path & ""
  6.     p1 = p & "2025"
  7.     p2 = p & "2026"
  8.     On Error Resume Next
  9.     For Each f In fso.GetFolder(p2).Files
  10.         f.Name = Split(fso.GetBaseName(f), "-")(0) & "-2026." & fso.GetExtensionName(f)
  11.     Next f
  12.     For Each f In fso.GetFolder(p1).Files
  13.         If LCase$(f.Name) Like "*.xls*" Then
  14.             fn = f.Name
  15.             Set wb = Workbooks.Open(f, 0)
  16.             Set wb2 = Workbooks.Open(p2 & fso.GetBaseName(f) & "-2026." & fso.GetExtensionName(f), 0)
  17.             For Each sht In wb.Sheets
  18.                 With sht
  19.                     r = .Cells(Rows.Count, "l").End(3).Row
  20.                     arr = .Range("l2:t" & r)
  21.                     xm = .Name
  22.                     wb2.Sheets(xm).Range("l2:t" & r) = arr
  23.                 End With
  24.             Next
  25.             wb.Close 0
  26.             wb2.Close 1
  27.         End If
  28.     Next f
  29.     For Each f In fso.GetFolder(p2).Files
  30.         f.Name = Split(fso.GetBaseName(f), "-")(0) & "." & fso.GetExtensionName(f)
  31.     Next f
  32.     Application.ScreenUpdating = True
  33.     MsgBox "OK!"
  34. End Sub

复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-20 19:04 | 显示全部楼层
本帖最后由 lqs1234 于 2025-1-20 19:09 编辑
杨建营 发表于 2025-1-20 18:12
文件无法打开,不知道是哪里的原因

刚下载试了一下,可以打开,这个是用EXCEL2007弄的

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-20 19:05 | 显示全部楼层
本帖最后由 lqs1234 于 2025-1-20 19:09 编辑
ykcbf1100 发表于 2025-1-20 18:47
因为不能同时打开二个同名文件,所以,多写了一些代码。

多谢了,我试试;

真的可以,这样再用的时候就不用手动复制粘贴了

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-20 20:28 | 显示全部楼层
试着用豆包AI编程写出来的VBA,其中修改了三次,最后可以正确运行,AI真的是太强大了,不过也会犯一些明显的错误,比如FOR的结束刚开始用了END FOR,说出运行错误行后进行了更改为NEXT i,因为楼上说不能同时打开两个同名文件,所以就把2026文件夹内的文件名更改了一下,刚开始运行也是提示不能打开同名文件。
水平比较菜,简单的可以看,但让我写是写不出来的,会写代码真的是可以提高不少工作的效率,省不少事,在此向各位热心的网友致谢了!
Sub 复制粘贴()
    Dim sourceFolder As String
    Dim targetFolder As String
    Dim sourceFile As String
    Dim targetFile As String
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim i As Integer
   
    sourceFolder = ThisWorkbook.Path & "\2025\" '源文件夹路径,可根据实际情况修改
    targetFolder = ThisWorkbook.Path & "\2026\" '目标文件夹路径,可根据实际情况修改
   
    '定义要操作的文件数组
    Dim files As Variant '将 files 声明为 Variant 类型
    files = Array("21.xlsx", "22.xlsx", "23.xlsx")
   
    For i = LBound(files) To UBound(files)
        sourceFile = sourceFolder & files(i)
        Select Case files(i)
            Case "21.xlsx"
                targetFile = targetFolder & "21-1.xlsx"
            Case "22.xlsx"
                targetFile = targetFolder & "22-2.xlsx"
            Case "23.xlsx"
                targetFile = targetFolder & "23-3.xlsx"
        End Select
        
        Set sourceWorkbook = Workbooks.Open(sourceFile)
        Set targetWorkbook = Workbooks.Open(targetFile)
        
        Set sourceSheet = sourceWorkbook.Sheets(1) '假设操作的是第一个工作表,可根据实际修改
        Set targetSheet = targetWorkbook.Sheets(1) '假设操作的是第一个工作表,可根据实际情况修改
        sourceSheet.Range("L:T").Copy Destination:=targetSheet.Range("L:T")
        
        Set sourceSheet = sourceWorkbook.Sheets(2) '假设操作的是第一个工作表,可根据实际修改
        Set targetSheet = targetWorkbook.Sheets(2) '假设操作的是第一个工作表,可根据实际情况修改
        
        '复制 L 到 T 列的内容
        sourceSheet.Range("L:T").Copy Destination:=targetSheet.Range("L:T")
        
        sourceWorkbook.Close SaveChanges:=False '关闭源工作簿,不保存更改
        targetWorkbook.Close SaveChanges:=True '关闭目标工作簿并保存更改
    Next i '将 End For 修改为 Next i
End Sub

TA的精华主题

TA的得分主题

发表于 2025-1-21 07:28 | 显示全部楼层
lqs1234 发表于 2025-1-20 20:28
试着用豆包AI编程写出来的VBA,其中修改了三次,最后可以正确运行,AI真的是太强大了,不过也会犯一些明显 ...

你这样把文件名写死了,如果换成别的文件就不能用了。

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-21 09:19 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
ykcbf1100 发表于 2025-1-21 07:28
你这样把文件名写死了,如果换成别的文件就不能用了。

是的,AI自动生成的不如你给的那个好用,多谢了
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

1234

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-2-18 15:40 , Processed in 0.024619 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表