Question

我正在尝试读取一列单元格，当它找到包含信息的单元格时，创建一个新的工作簿并使用该单元格作为名称。我正在尝试将其保存到名为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 文件夹（无论操作系统路径如何都有效）
代码创建一个工作表空白工作簿，然后将其保存在此目录中作为要创建的新文件的模板
效率FileCopy用于制作新版本，而不是重复创建，保存和关闭新工作
跳过空值
代码使用变量数组来快速处理值

如果您的数据格式不同，可能还需要进行一些小的调整。例如，测试不能在文件名中使用的字符。

<强>码

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

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

1 个答案: