复制并生成新文件的问题

杨小妹

附件 复制并生成新文件.rar (337.3 KB, 下载次数: 11)

2024-3-9 17:50 上传

点击文件名下载附件

谢谢老师！

fzxba

复制并生成新文件.rar (392.13 KB, 下载次数: 12)

2024-3-9 19:15 上传

点击文件名下载附件

风雨声点滴

Sub xx()
Dim a As Workbook, b As Workbook, c As Long, d As Long, e As Long
Set a = Workbooks("55")
Set b = Workbooks("程序")
c = a.Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
d = a.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For e = 1 To c
  b.Sheets("sheet1").Range("c1:c" & d).Value = a.Sheets("sheet1").Cells(1, e).Resize(d, 1).Value
  b.SaveAs Filename:="C:\Users\MH731\Desktop\新建文件夹\a" & e & ".xlsm"    '另存为路径
Next e
   a.Close SaveChanges:=False '不保存关闭
   b.Close SaveChanges:=False '不保存关闭
End Sub

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, j&, strFileName$, strPath$, wSht As Sheets
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "55.xlsx"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Set wSht = Worksheets(Array("Sheet1", "Sheet2"))
    With GetObject(strFileName)
        ar = .Sheets(1).[A1].CurrentRegion.Value
        .Close False
    End With
   
    For j = 1 To UBound(ar, 2)
        wSht.Copy
        strFileName = strPath & "A" & j
        With ActiveWorkbook
            .Worksheets(1).[C1].Resize(UBound(ar)) = Application.Index(ar, , j)
            .SaveAs strFileName, 52
            .Close
        End With
    Next j

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

请参考。。。