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

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

示例：NAME1.xls，NAME2.xls

并且新生成的文件必须只包含标记####中包含的单元格

（见IMG…第4单元：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

试试这个：

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:\”选择其他文件夹。您可能需要管理员权限才能在那里保存。

好的，开始吧。这将获取您正在查找的原始工作簿的块，并将其保存为多个新工作簿

选项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

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

选项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 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

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保留格式设置，并选择两个单元格中包含

###

的区域

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

---

这不是一个代码编写服务。请显示您已经尝试过的内容、问题并添加代码。人们来这里是为了帮助别人自己解决问题，而不是为他们做所有的工作。阅读也可能有帮助。@Peh我已经编辑了我的问题，可以吗？x1OpenXMLWorkbook[sic]不是XLS格式，强制使用.XLS文件扩展名并不能改变这一点。谷歌msdn vba saveas并检查文件格式。它必须是

xl

而不是

x1

，这是一个小

L

而不是一个！我很确定我的答案是正确的：）我做了一些测试。这似乎有效，但如果标记移动得更低。。。如果我添加了更多的行，那么@Marcucciboy2就不起作用了……另一个问题是它不能保持单元格的格式（颜色、大小等等）问题1：这是因为我指定了

wksht.Range（“C3:U33”）

来匹配发布的示例。我可以很容易地让它抓住你床单上的最低点，但如果你移动它，我就无法很容易地让它与起点匹配。对于问题2，是的，我将不得不从使用数组改为复制和粘贴。我没有意识到你有特殊的格式，我只是使用了这个例子。如果你的工作表真的使用了

####

标记，那么它实际上会很漂亮easy@Marcuccuboy2你是个天才。选项5是解决方案。。非常感谢。