循环复制单元名称作为新的工作簿

我想读取一列单元格，当它发现一个单元格中的信息创build一个新的工作簿，并使用该单元格作为名称。 我试图将其保存到名为Book1的桌面上的文件夹中。 我有点卡住，不知道下一步该去哪里？

Sub blair() Dim Aname As String For ptr = 2 To 300 If Cells(ptr, "b") = vbNullString Then Cells(ptr, "b") = Cells(ptr, "a").Offset(-1, 0) ElseIf Cells(ptr, "b") > 0 Then Aname = ActiveCell.Value Workbooks.Add ActiveWorkbook.SaveAs Filename:=Aname & ".xls" End If Next End Sub 

Answer 1

一个选项在下面。

• 检查用户桌面上是否存在Book1文件夹（不pipe操作系统path如何）
• 代码将创build一个表单空白工作簿，然后将其保存在此目录中作为要创build的新文件的模板
• 为了提高效率， FileCopy用于创build新版本，而不是反复创build，保存和closures新的工作
• 空值被跳过
• 代码使用变体数组来快速处理值

如果你的数据格式不同，可能需要进一步的小调整。 例如，testing不能在文件名中使用的字符。

码

 Sub NB() Dim X Dim lngCnt As Long Dim strDT As String Dim strNewBook As String Dim objWS As Object Dim WB As Workbook Dim bNewBook As Boolean Set objWS = CreateObject("WScript.Shell") strDT = objWS.SpecialFolders("Desktop") & "\Book1" If Len(Dir(strDT, vbDirectory)) = 0 Then MsgBox "No such directory", vbCritical Exit Sub End If X = Range([a1], Cells(Rows.Count, "A").End(xlUp)).Value2 For lngCnt = 1 To UBound(X, 1) If Len(X(lngCnt, 1)) > 0 Then If Not bNewBook Then 'make a single sheet workbook for first value Set WB = Workbooks.Add(1) WB.SaveAs strDT & "\" & X(lngCnt, 1) & ".xls" strNewBook = WB.FullName WB.Close bNewBook = True Else FileCopy strNewBook, strDT & "\" & X(lngCnt, 1) & ".xls" End If End If Next End Sub