批量另存

zggdszsjwfb

制作一个宏，要求复制单元格B2的内容20到原文件.XLS中BOM工作表中A3单元格,并以该单元格A3里的内 容为名称,也就是20,另存到明细文件夹里,然后再复制单元格B3的内容19到原文件.XLS中BOM工作表中A3单元格,并以该单元格A3里的内 容为名称,也就是19,另存到明细文件夹里,依次执行.
注意:每次宏执行可以选择从多少行开始到多少行结束,也就是可以从序号5开始到序号10结束,也可以从序号3开始到序号11结束,这个可以自由选择.

yangyangzhifeng

试试看

1. Sub test()
   
2.     Dim ar, i&, istart&, istop&
   
3.     On Error Resume Next
   
4.     istart = InputBox("请输入起始值", "起始值") + 1
   
5.     istop = InputBox("请输入结束值", "结束值") + 1
   
6.     ar = Sheet1.Range("a1").CurrentRegion
   
7.     Workbooks.Open ThisWorkbook.Path & "\原文件.xls"
   
8.     With Workbooks("原文件.xls").Sheets("BOM")
   
9.         For i = istart To istop
   
10.             .Range("a3") = ar(i, 2)
    
11.             ActiveWorkbook.SaveAs ThisWorkbook.Path & "\明细" & ar(i, 2) & ".xls"
    
12.         Next
    
13.     End With
    
14.     ActiveWorkbook.Close
    
15. End Sub

复制代码

zhaogang1960

1. Sub Macro1()
   
2.     Dim FirstRow, LastRow, arr, i&, f$, p1$, p$, lr&
   
3.     Dim cnn As Object, SQL$, t
   
4.     p1 = ThisWorkbook.Path & ""
   
5.     f = p1 & "原文件.xls"
   
6.     lr = Range("a65536").End(xlUp).Row - 1
   
7.     Do
   
8.         FirstRow = InputBox(Prompt:="请输入开始序号：>=1且<=" & lr, Title:="输入开始序号", Default:=1)
   
9.         If StrPtr(FirstRow) = 0 Then Exit Sub
   
10.     Loop Until Val(FirstRow) > 0 And Val(FirstRow) <= lr
    
11.     Do
    
12.         LastRow = InputBox(Prompt:="请输入结束序号：>=" & FirstRow & "且<=" & lr, Title:="输入结束序号", Default:=lr)
    
13.         If StrPtr(LastRow) = 0 Then Exit Sub
    
14.     Loop Until Val(LastRow) >= FirstRow And Val(LastRow) <= lr
    
15.     arr = Range("a" & FirstRow + 1).Resize(lr - FirstRow + 1, 2)
    
16.     For i = 1 To UBound(arr)
    
17.         If Len(arr(i, 2)) Then
    
18.             p = p1 & "明细" & arr(i, 2) & ".xls"
    
19.             If Dir(p) <> "" Then Kill p
    
20.             FileCopy f, p
    
21.             Set cnn = CreateObject("ADODB.Connection")
    
22.             cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;hdr=no';Data Source =" & p
    
23.             If IsNumeric(arr(i, 2)) Then
    
24.                 t = arr(i, 2)
    
25.             Else
    
26.                 t = "'" & arr(i, 2) & "'"
    
27.             End If
    
28.             SQL = "update [BOM$a3:a3] set f1 =" & t
    
29.             cnn.Execute SQL
    
30.         End If
    
31.     Next
    
32.     cnn.Close
    
33.     Set cnn = Nothing
    
34.     MsgBox "ok"
    
35. End Sub
    
36. 请测试：

复制代码

zhaogang1960

请看附件
批量制作.rar (14.81 KB, 下载次数: 84)

2012-9-29 21:56 上传

点击文件名下载附件

zggdszsjwfb

zhaogang1960 发表于 2012-9-29 21:56
请看附件

非常感谢,问题解决了.另个有时间帮忙看一下这个问题:http://club.excelhome.net/thread-926660-1-1.html谢谢!

zggdszsjwfb

zhaogang1960 发表于 2012-9-29 21:56
请看附件

在家里的电脑测试没有问题，公司的两台电脑都出现问题，不管输入的序号是多少，都另存全部的序号。能帮忙看看是什么问题

zhaogang1960

zggdszsjwfb 发表于 2012-10-4 17:30
在家里的电脑测试没有问题，公司的两台电脑都出现问题，不管输入的序号是多少，都另存全部的序号。能帮忙 ...

估计你在公司的附件有问题，请上传出问题的附件分析一下

zggdszsjwfb

zhaogang1960 发表于 2012-10-4 17:43
估计你在公司的附件有问题，请上传出问题的附件分析一下

是上次上传的同一个附件。在家里的电脑测试可以，公司的电脑就不行。不知为什么？

zhaogang1960

zggdszsjwfb 发表于 2012-10-4 20:54
是上次上传的同一个附件。在家里的电脑测试可以，公司的电脑就不行。不知为什么？

是cnn.Open ……这一句出错？可能不支持ADO，使用2楼代码吧

zggdszsjwfb

zhaogang1960 发表于 2012-10-4 21:28
是cnn.Open ……这一句出错？可能不支持ADO，使用2楼代码吧

运行时不显示出错，只是不管输入的序号是多少，都另存全部的序号，明天到公司试一下2楼的代码。