使用文件名单元格值保存新文件 excel

Question

我需要生成很多 .xls 文件重命名为 A1、A2、A3 行中包含的名称....

示例：NAME1.xls、NAME2.xls ...

并且新生成的文件必须仅包含标记 ####

中包含的单元格

（参见 IMG...cellD4:T32）

我手动输入的标记变化。

我试过这段代码只是为了保存新的 .xls 文件但它不起作用....我不知道该怎么做剩下的

Private Sub CommandButton1_Clickl()
Dim path As String
Dim filename1 As String

path = "C:\"
filename1 = Range("A1").Text
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=path & filename1 & ".xls", FileFormat:=x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close



End Sub

Answer 1

试试这个：

Sub filename()
Dim i As Integer
For i = 1 To 32
    ChDir "C:\path\"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\path\" & Range("A" & i).Value & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Next i
End Sub

注意：不要使用"C:\"选择另一个文件夹。可能您需要管理员权限才能保存在那里。

Answer 2

好的，开始吧。这应该抓取您要查找的原始工作簿的块并将其保存为多个新工作簿。

选项 1 删除格式

Private Sub CommandButton1_Clickl()

    Dim wksht As Worksheet
    Set wksht = ActiveSheet

    Dim path As String
    path = "C:\test\"

    If Len(Dir(path, vbDirectory)) = 0 Then
        MkDir path
    End If

    Dim arr() As Variant
    arr = wksht.Range("C3:U33").value

    Dim wb As Workbook
    Dim i As Long

    For i = 1 To ActiveSheet.Range("A1").End(xlDown).Row
        Set wb = Application.Workbooks.Add
        wb.Sheets(1).Range("A1", Cells(UBound(arr), UBound(arr, 2))).value = arr
        wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
        wb.Close
    Next i

End Sub

选项 2 保持格式化

Private Sub CommandButton1_Clickl()

    Dim wksht As Worksheet
    Set wksht = ActiveSheet

    Dim path As String
    path = "C:\test\"

    If Len(Dir(path, vbDirectory)) = 0 Then
        MkDir path
    End If

    Dim dataRange As Range
    Set dataRange = wksht.Range("C3", wksht.UsedRange.SpecialCells(xlCellTypeLastCell))

    Dim wb As Workbook
    Dim i As Long

    For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
        Set wb = Application.Workbooks.Add
        dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
        wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
        wb.Close
    Next i

End Sub

但请注意，根据给出的示例，起点仍然是 C3。

选项 3 保持格式并选择包含 #### 的 2 个单元格之间的范围

Private Sub CommandButton1_Clickl()

    Dim wksht As Worksheet
    Set wksht = ActiveSheet

    Dim path As String
    path = "C:\test\"

    If Len(Dir(path, vbDirectory)) = 0 Then
        MkDir path
    End If

    Dim rngeStart
    Dim rngeEnd

    Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
    Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)

    Dim dataRange As Range
    Set dataRange = wksht.Range(rngeStart, rngeEnd)

    Dim wb As Workbook
    Dim i As Long

    For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
        Set wb = Application.Workbooks.Add
        dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
        wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
        wb.Close
    Next i

End Sub

选项 5 保持行高和列宽

Private Sub CommandButton1_Clickl()

    Dim wksht As Worksheet
    Set wksht = ActiveSheet

    Dim path As String
    path = "C:\test\"

    If Len(Dir(path, vbDirectory)) = 0 Then
        MkDir path
    End If

    Dim rngeStart
    Dim rngeEnd

    Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
    Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)

    Dim dataRange As Range
    Set dataRange = wksht.Range(rngeStart, rngeEnd)

    Dim newDataRange As Range

    Dim wb As Workbook
    Dim i As Long
    Dim j As Long
    Dim k As Long

    For i = 1 To wksht.Range("A" & wksht.Rows.Count).End(xlUp).Row
        Set wb = Application.Workbooks.Add
        Set newDataRange = wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.Rows.Count, dataRange.Columns.Count))
        dataRange.Copy newDataRange
        For j = 1 To dataRange.Columns.Count
            newDataRange.Cells(1, j).ColumnWidth = dataRange.Cells(1, j).ColumnWidth
        Next j
        For k = 1 To dataRange.Rows.Count
            newDataRange.Cells(k, 1).RowHeight = dataRange.Cells(k, 1).RowHeight
        Next k
        wb.SaveAs filename:=path & wksht.Range("A" & i).Value & ".xlsx"
        wb.Close
    Next i

End Sub

使用文件名单元格值保存新文件 excel

Save new file excel with filename cell value

excel

vba

export-to-excel