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

好的，你走了。这应该抓住您正在寻找的原始工作簿的大块，并将其保存为多个新工作簿。

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

Answer 2

试试这个：

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

注意：不要使用＆＃34; C：\＆＃34;选择其他文件夹。可能你需要管理员权限才能保存。

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

2 个答案: