查看: 2339|回复: 5
如何将Excel总表中每行内容自动填到分表的单元格中，并按分表单独自动生成新文件
阅读权限10
在线时间 小时
& & & & & & & &
求助大神：
我遇到一个Excel的问题，需要将设备清单（总表）中每行的内容自动填到设备参数表（分表）中的对应单元格中，然后自动在本路径下保存成按设备号为文件名保存为单独的Excel文件。
如下图示意的对应关系
要求的结果是：
点击《水泵参数表》中的“生成单个泵的参数表”按钮，Excel自动按示意图的对应关系按《水泵清单》表格先从第一行自动提取内容到《水泵参数表》，然后自动生成一个只含第一个泵内容的《水泵参数表》，并在本路径下保存为：P-101.xls文件。然后再提取《水泵清单》表格第二行的内容，同样生成一个文件P-102.xls。以此类推。直到《水泵清单》最后一个泵为止。
实际的表格远比这个复杂，我示意性做了这个表格。由于本人不太懂VBA，求大神帮忙做个VBA代码，我好参照着改为实际使用的表格代码。
谢谢了！！！！！
(108.16 KB, 下载次数: 4)
22:40 上传
22:56 上传
点击文件名下载附件
6.84 KB, 下载次数: 32
阅读权限20
在线时间 小时
Sub test()
& & Dim wb As Workbook, sh As Worksheet, arr, x
& & Set sh = Sheets(&水泵参数表&)
& & arr = Range(&a1:n& & Cells(Rows.Count, 1).End(xlUp).Row)
& & Application.DisplayAlerts = False
& & Application.ScreenUpdating = False
& & For x = 5 To UBound(arr)
& && &&&sh.[b6] = arr(x, 2)
& && &&&sh.[b8] = arr(x, 4)
& && &&&sh.[b9] = arr(x, 5)
& && &&&sh.[b10] = arr(x, 6)
& && &&&sh.[b11] = arr(x, 7)
& && &&&sh.[b14] = arr(x, 12)
& && &&&sh.[b15] = arr(x, 13)
& && &&&sh.[e6] = arr(x, 3)
& && &&&sh.[e8] = arr(x, 8)
& && &&&sh.[e9] = arr(x, 10)
& && &&&sh.[e10] = arr(x, 11)
& && &&&sh.[e11] = arr(x, 12)
& && &&&sh.Copy
& && &&&Set wb = ActiveWorkbook
& && &&&wb.SaveAs ThisWorkbook.Path & && & arr(x, 2) & &.xls&, FileFormat:=xlExcel8
& && &&&wb.Close
& & Next
& & Application.DisplayAlerts = True
& & Application.ScreenUpdating = True
End Sub复制代码
阅读权限20
在线时间 小时
请查看附件
(13.82 KB, 下载次数: 139)
23:40 上传
点击文件名下载附件
阅读权限10
在线时间 小时
& & & & & & & &
请查看附件
非常感谢你的帮助！你的代码很简洁却很有用，受教了:-)
阅读权限10
在线时间 小时
借助参考下大神代码。多谢，正要用
阅读权限10
在线时间 小时
& & & & & & & &
请查看附件
你的代码不知道为什么只能显示第一个数据，然后显示400错误。求大神指点
最新热点 /1
Excel三大神器，函数、数据透视表、VBA，分分钟学起来！
原价257元，领券后仅需126元，相当于4.9折！优惠券数量有限，先到先得。活动时间：即日起至12月14日。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师查看: 889|回复: 7
如何批量把文件夹中的文件名由excel中A列的文件名改成B列的文件名
阅读权限10
在线时间 小时
(19.73 KB, 下载次数: 8)
20:35 上传
点击文件名下载附件
excel中已经写了一些代码但是还是不能实现，麻烦各位高手帮帮忙谢谢啦
阅读权限20
在线时间 小时
其实也可以用批处理
阅读权限70
在线时间 小时
Sub ReName()
& & Dim Ar
& & Dim I& && && &&&As Long
& & Dim FilePath& & As String
& & On Error Resume Next
& & FilePath = &D:&& && && &&&'自己修改
& & Ar = Range(&A2:A& & Range(&B& & Rows.Count).End(xlUp).Row)
& & For I = 1 To UBound(Ar)
& && &&&Name FilePath & Ar(I, 1) As FilePath & Ar(I, 2)
& & Next
End Sub复制代码
阅读权限10
在线时间 小时
crazy0qwer 发表于
似乎没有成功~~
阅读权限70
在线时间 小时
Air_Bee1987 发表于
似乎没有成功~~
代码呢？？？
阅读权限10
在线时间 小时
crazy0qwer 发表于
代码呢？？？
我把三楼的代码放在excel中但是没有成功
阅读权限70
在线时间 小时
Air_Bee1987 发表于
我把三楼的代码放在excel中但是没有成功
额，抱歉，获取数据的时候应该是 A1：B 。。。Sub ReName()
& & Dim Ar
& & Dim I& && && &&&As Long
& & Dim FilePath& & As String
& & FilePath = ThisWorkbook.Path & &&& && && &&&'自己修改
& & Ar = Range(&A2:B& & Range(&B& & Rows.Count).End(xlUp).Row)
& & For I = 1 To UBound(Ar)
& && &&&If Dir(FilePath & Ar(I, 1)) && && Then
& && && && &Name FilePath & Ar(I, 1) As FilePath & Ar(I, 2)
& && &&&End If
& & Next
& & MsgBox &完成&
End Sub
复制代码
(8.49 KB, 下载次数: 23)
22:07 上传
点击文件名下载附件
阅读权限10
在线时间 小时
crazy0qwer 发表于
额，抱歉，获取数据的时候应该是 A1：B 。。。
非常感谢~~
最新热点 /1
Excel三大神器，函数、数据透视表、VBA，分分钟学起来！
原价257元，领券后仅需126元，相当于4.9折！优惠券数量有限，先到先得。活动时间：即日起至12月14日。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师查看: 1258|回复: 11
如何用VBA从多个表中分月提取某两列数据
阅读权限10
在线时间 小时
&&求助：如附件，一个文件夹中含有多个表，其中有一个汇总表，需要每个月从文件夹中其他表提取C、D两列数据到汇总表的每月里面去，如何通过VBA来完成，求高手解决，谢谢！
13:49 上传
点击文件名下载附件
50.41 KB, 下载次数: 72
阅读权限100
在线时间 小时
Sub lqxs()
& & Dim Arr, myPath$, myName$, aa, col%, nm$
& & Application.ScreenUpdating = False
& & Sheet1.Activate
& & nm = ThisWorkbook.Name
& & [c4:z5000].ClearContents
& & myPath = ThisWorkbook.Path & &&
& & myName = Dir(myPath & &*.xlsx&)
& & Do While myName && &&
& && &&&If myName && nm Then
& && &&&With GetObject(myPath & myName)
& && && && &Arr = .Sheets(1).Range(&A1&).CurrentRegion
& && && && &Arr = .Sheets(1).Range(&c4&).Resize(UBound(Arr) - 3, 2)
& && && && &.Close False
& && &&&End With
& && &&&aa = Split(myName, &.&)(0)
& && &&&col = Val(Mid(aa, 2))
& && &&&col = 2 * col + 1
& && &&&Cells(4, col).Resize(UBound(Arr), 2) = Arr
& && &&&End If
& && &&&myName = Dir
& & Loop
& & Application.ScreenUpdating = True
End Sub
阅读权限100
在线时间 小时
(20.45 KB, 下载次数: 109)
15:55 上传
点击文件名下载附件
请见附件。
阅读权限20
在线时间 小时
& & & & & & & &
请见附件。
蓝版主，我一个问题，帮我解决一下，万分感谢了。
阅读权限10
在线时间 小时
老师，您好，我在实际操作时遇到了问题；我从提取的表格里面有多个表，需要提取的列的表格为第十个表，表名‘损益表’，表头的月份合并了10个单元格，请问我要对以上代码做怎样的更改呢
阅读权限100
在线时间 小时
老师，您好，我在实际操作时遇到了问题；我从提取的表格里面有多个表，需要提取的列的表格为第十个表，表 ...
建议上传表格附件来说明问题。
阅读权限10
在线时间 小时
建议上传表格附件来说明问题。
&&附件如下，汇总表不变，取事业部损益表中CD两列。
12:50 上传
点击文件名下载附件
84.35 KB, 下载次数: 42
阅读权限100
在线时间 小时
Sub lqxs()
& & Dim Arr, myPath$, myName$, aa, col%, nm$
& & Application.ScreenUpdating = False
& & Sheet1.Activate
& & nm = ThisWorkbook.Name
& & [c4:z5000].ClearContents
& & myPath = ThisWorkbook.Path & &&
& & myName = Dir(myPath & &*.xlsx&)
& & Do While myName && &&
& && &&&If myName && nm Then
& && &&&With GetObject(myPath & myName)
& && && && &Arr = .Sheets(&事业部损益表&).Range(&A1&).CurrentRegion
& && && && &Arr = .Sheets(&事业部损益表&).Range(&c4&).Resize(UBound(Arr) - 3, 2)
& && && && &.Close False
& && &&&End With
& && &&&aa = Split(myName, &.&)(0)
& && &&&col = Val(Mid(aa, 2))
& && &&&col = 2 * col + 1
& && &&&Cells(4, col).Resize(UBound(Arr), 2) = Arr
& && &&&End If
& && &&&myName = Dir
& & Loop
& & Application.ScreenUpdating = True
End Sub
复制代码
另存为“汇总表.xlsm”& &,并且把“汇总表.xlsx” 删除。
阅读权限30
在线时间 小时
如果费用项目名称位置不一致，如果匹配上呢？
阅读权限30
在线时间 小时
我V2表格的部分项目删除，请问项目如何匹配上
14:18 上传
点击文件名下载附件
94.54 KB, 下载次数: 24
最新热点 /1
Excel三大神器，函数、数据透视表、VBA，分分钟学起来！
原价257元，领券后仅需126元，相当于4.9折！优惠券数量有限，先到先得。活动时间：即日起至12月14日。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师查看: 601|回复: 4
如何将工作表按某列为字段分开并批量生成文本文件
阅读权限20
在线时间 小时
源数据附上！
需以J列将数据拆分成多个工作表，并批量生成以J列命名的文本文档，但文本文档中不出现J列。
如找出08872对应的所有行，生成名为“08872”的文本文档，但文本文档中不出现“08872”（见附件）
不胜感谢！
(890.79 KB, 下载次数: 8)
14:48 上传
点击文件名下载附件
阅读权限70
在线时间 小时
Private Sub CommandButton1_Click()
& & Dim Cnn As New ADODB.Connection
& & Dim Rst As New ADODB.Recordset
& & Dim SQL$, Tname$, Tn%
& & Dim i%, r%, k%
& & Dim Arr(), Brr()
& &
& & Application.DisplayAlerts = False
& & Application.ScreenUpdating = False
& &
& & ThisWorkbook.ChangeFileAccess xlReadOnly
& & Cnn.Open &Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=& & ThisWorkbook.FullName
& & r = Range(&A& & Rows.Count).End(xlUp).Row
& & SQL = &SELECT DISTINCT F10 FROM [Sheet1$A1:J& & r & &]&
& & Rst.Open SQL, Cnn, 1, 3
& & Arr = WorksheetFunction.Transpose(Rst.GetRows)
& & Rst.Close
& &
& & For i = 1 To UBound(Arr)
& && &&&Tname = ThisWorkbook.Path & && & Arr(i, 1) & &.txt&
& && &&&If Len(Dir(Tname)) Then Kill Tname
& && &&&SQL = &SELECT F1,F2,F3,F4,F5,F5,F6,F7,F8,F9 FROM [Sheet1$A1:J& & r & &] WHERE F10='& & Arr(i, 1) & &'&
& && &&&Rst.Open SQL, Cnn, 1, 3
& && &&&Brr = WorksheetFunction.Transpose(Rst.GetRows)
& && &&&Tn = FreeFile()
& && &&&
& && &&&Open Tname For Output As #Tn
& && &&&For k = 1 To UBound(Brr)
& && && && &Write #Tn, Join(WorksheetFunction.Index(Brr, 1, 0), Chr(9))
& && &&&Next k
& && &&&Close #Tn
& && &&&Rst.Close
& & Next
& & Cnn.Close
& &
& & ThisWorkbook.ChangeFileAccess xlReadWrite
& & Application.DisplayAlerts = True
& & Application.ScreenUpdating = True
& &
& & MsgBox &已完成&
End Sub复制代码
阅读权限70
在线时间 小时
附件在此，请审核
16:05 上传
点击文件名下载附件
1.02 MB, 下载次数: 8
阅读权限20
在线时间 小时
LIUZHU 发表于
附件在此，请审核
非常感谢！很不错！
有两个问题：1、生成的文本中前后各有一个引号，这个不需要；2、每项之间不能是空格（制表符分隔），挨在一起。
请帮忙继续优化，谢谢！
阅读权限20
在线时间 小时
LIUZHU 发表于
附件在此，请审核
还有这段代码能不能设置任意列？
即列数不固定的
最新热点 /1
Excel三大神器，函数、数据透视表、VBA，分分钟学起来！
原价257元，领券后仅需126元，相当于4.9折！优惠券数量有限，先到先得。活动时间：即日起至12月14日。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师查看: 2594|回复: 10
如何提取出多个Excel工作簿中相同字段的数据并生成新的文件？
阅读权限20
在线时间 小时
文件夹里总共有65个这样的工作簿，每个工作簿里只有一个sheet表，sheet表是以每个工作簿的名字命名的。里面A列字段都有重合的。
现在要把每个工作薄的A列 每一个相同字段如65027的数据都提取出来生成一个新的excel或文本文档并以字段名（如65027）为文件名。
因为数据量特别大，每个工作簿都是上万行，而且这些相同字段名的总共有400多个。
请教一下高手，这个应该如何在excel中实现。。感激不尽
09:41 上传
点击文件名下载附件
7.44 KB, 下载次数: 91
阅读权限95
在线时间 小时
& & Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, p$, i&, n&
& & Application.ScreenUpdating = False
& & Application.DisplayAlerts = False
& & p = ThisWorkbook.Path & &\结果\&
& & If Dir(p, vbDirectory) = && Then MkDir p
& & Set Fso = CreateObject(&Scripting.FileSystemObject&)
& & Set cnn = CreateObject(&adodb.connection&)
& & For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
& && &&&If File.Name Like &*.xlsx& Then
& && && && &n = n + 1
& && && && &If n = 1 Then cnn.Open &provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=no';data source=& & File
& && && && &SQL = &select distinct f1 from [Excel 12.0;hdr=Database=& & File & &;].[& & Replace(File.Name, &.xlsx&, &&) & &$] where f1 is not null&
& && && && &Set rs = cnn.Execute(SQL)
& && && && &arr = rs.GetRows
& && && && &For i = 0 To UBound(arr, 2)
& && && && && & SQL = &select * from [Excel 12.0;hdr=Database=& & File & &;].[& & Replace(File.Name, &.xlsx&, &&) & &$] where f1=& & arr(0, i)
& && && && && & With Workbooks.Add(xlWBATWorksheet)
& && && && && && &&&.ActiveSheet.Range(&a1&).CopyFromRecordset cnn.Execute(SQL)
& && && && && && &&&.SaveAs p & arr(0, i) & &.xlsx&
& && && && && && &&&.Close
& && && && && & End With
& && && && &Next
& && &&&End If
& & rs.Close
& & cnn.Close
& & Set rs = Nothing
& & Set cnn = Nothing
& & Set Fso = Nothing
& & Application.ScreenUpdating = True
阅读权限95
在线时间 小时
结果放在“结果”文件夹中，请注意，如果65个工作簿中的A列有重复，则后面生成的工作簿会覆盖前面的
请测试附件
(23.46 KB, 下载次数: 100)
10:06 上传
点击文件名下载附件
阅读权限20
在线时间 小时
结果放在“结果”文件夹中，请注意，如果65个工作簿中的A列有重复，则后面生成的工作簿会覆盖前面的
我把xlsm文件复制到目标文件夹下面 已经运行几个小时了，A列的字段是重复的 但重复字段所在行的数据不是重复的，年月日的日期不一样，这样的工作簿还会被覆盖吗？
阅读权限95
在线时间 小时
我把xlsm文件复制到目标文件夹下面 已经运行几个小时了，A列的字段是重复的 但重复字段所在行的数据不是 ...
请多上传了几个工作簿，并模拟需要的效果
阅读权限20
在线时间 小时
请多上传了几个工作簿，并模拟需要的效果
可能我没有表述清楚，就是原来的工作簿是 每一年 所有点 的数据，现在要的工作簿是 每个点 所有年 的数据。
我把示例更新了一下，麻烦这位老师指点一下，感激不尽~~~
15:39 上传
点击文件名下载附件
143.66 KB, 下载次数: 69
阅读权限95
在线时间 小时
可能我没有表述清楚，就是原来的工作簿是 每一年 所有点 的数据，现在要的工作簿是 每个点 所有年 的数据 ...
& & Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, p$, a, b, arr(), brr(1 To ), i&, j&, n&, m&, c&, d As Object
& & Application.ScreenUpdating = False
& & Application.DisplayAlerts = False
& & Set d = CreateObject(&scripting.dictionary&)
& & p = ThisWorkbook.Path & &\结果\&
& & If Dir(p, vbDirectory) = && Then MkDir p
& & Set Fso = CreateObject(&Scripting.FileSystemObject&)
& & Set cnn = CreateObject(&adodb.connection&)
& & ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count)
& & For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
& && &&&If File.Name Like &*.xlsx& Then
& && && && &n = n + 1
& && && && &If n = 1 Then cnn.Open &provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=no';data source=& & File
& && && && &SQL = &select * from [Excel 12.0;hdr=Database=& & File & &;].[& & Replace(File.Name, &.xlsx&, &&) & &$] where f1 is not null&
& && && && &Set rs = cnn.Execute(SQL)
& && && && &arr(n) = rs.GetRows
& && && && &For i = 0 To UBound(arr(n), 2)
& && && && && & d(arr(n)(0, i)) = d(arr(n)(0, i)) & &|& & n & &,& & i
& && && && &Next
& && &&&End If
& & k = d.keys
& & t = d.items
& & For l = 0 To d.Count - 1
& && &&&m = 0
& && &&&a = Split(t(l), &|&)
& && &&&For i = 1 To UBound(a)
& && && && &m = m + 1
& && && && &b = Split(a(i), &,&)
& && && && &n = b(0)
& && && && &c = b(1)
& && && && &For j = 0 To 4
& && && && && & brr(m, j) = arr(n)(j, c)
& && && && &Next
& && &&&Next
& && &&&With Workbooks.Add(xlWBATWorksheet)
& && && && &.ActiveSheet.Range(&a1&).Resize(m, 5) = brr
& && && && &.SaveAs p & k(l) & &.xlsx&
& && && && &.Close
& && &&&End With
& && &&&Erase brr
& & rs.Close
& & cnn.Close
& & Set rs = Nothing
& & Set cnn = Nothing
& & Set Fso = Nothing
& & Application.ScreenUpdating = True
& & MsgBox &OK&
阅读权限95
在线时间 小时
请测试附件
(79.1 KB, 下载次数: 165)
19:17 上传
点击文件名下载附件
阅读权限20
在线时间 小时
请测试附件
太厉害了！完美解决了我的问题，这个论坛真是太强大了。感谢高手！！
阅读权限70
在线时间 小时
& & Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, p$, i ...
赵老师您好：麻烦修改一下这个代码
13:29 上传
点击文件名下载附件
329.01 KB, 下载次数: 6
最新热点 /1
Excel三大神器，函数、数据透视表、VBA，分分钟学起来！
原价257元，领券后仅需126元，相当于4.9折！优惠券数量有限，先到先得。活动时间：即日起至12月14日。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师