1

我正在尝试读取一列单元格，当它找到一个包含信息的单元格时，会创建一个新的工作簿并将该单元格用作名称。我正在尝试将其保存到桌面上名为 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
4

1 回答 1

2

下面是一个选项。

  • 检查用户桌面上是否存在Book1文件夹（无论操作系统路径如何）
  • 该代码创建一个单张空白工作簿，然后将其保存在此目录中作为要创建的新文件的模板
  • 效率FileCopy是用来制作新版本的，而不是反复创建、保存和关闭一个新的workook
  • 空值被跳过
  • 该代码使用变量数组来快速处理值

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

代码

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
于 2013-07-13T07:09:27.547 回答