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

1 つのオプションを以下に示します。

  • Book1フォルダーがユーザーのデスクトップに存在することを確認します (OS パスに関係なく機能します)。
  • コードは 1 枚の空白のワークブックを作成し、作成する新しいファイルのテンプレートとしてこのディレクトリに保存します。
  • FileCopy新しいワークブックを繰り返し作成、保存、閉じるのではなく、効率的に新しいバージョンを作成するために使用されます
  • null 値はスキップされます
  • コードは、値の迅速な処理のためにバリアント配列を使用します

データ形式が異なる場合は、さらに微調整が必​​要になる場合があります。たとえば、ファイル名に使用できない文字のテスト。

コード

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 に答える