Question

我有这段代码将数据从一个工作簿中的范围复制到特定模板的Sheet1。（Sheet1中的数据然后填充模板文件中的第二个工作表。）为“names1”范围内的名称创建并命名每个文件。

这似乎完美无缺，但我还需要做其他两件事：

首先，我需要检查并查看是否已使用文件名创建文件，如果是，则不覆盖它，或提示保存。
其次，最重要的是，我需要找到一种方法让它检查现有文件，然后只用上面的信息覆盖Sheet1，不改变文件中任何其他工作表上的任何内容，然后保存并关闭文件。然后继续检查文件中的所有其他名称，并从模板创建一个新文件（如我的代码所示）或仅更新sheet1并保存/关闭文件。

我已经在这方面寻求了帮助，但由于我对VBA的了解有限，我不确定将加载项放在哪里以及使用什么语法。任何帮助将不胜感激!!!

这是我的工作代码：

Sub Smart1()

Dim src As Workbook
Dim dst As Workbook
SavePath = ActiveWorkbook.Path

Set src = ActiveWorkbook

For Each C In Range("Names1")

i = C.Row

Name = Cells(i, 44).Value
PSFFAll = Cells(i, 45).Value
CLSFall = Cells(i, 46).Value
CLSWin = Cells(i, 47).Value
CLSEnd = Cells(i, 48).Value
WWRFall = Cells(i, 49).Value
WWRWin = Cells(i, 50).Value
WWREnd = Cells(i, 51).Value
DORFWin = Cells(i, 52).Value
DORFEnd = Cells(i, 53).Value
AccWin = Cells(i, 54).Value
AccEnd = Cells(i, 55).Value

fname = Cells(i, 44).Value & ".xlsx"

Workbooks.Open FileName:=ThisWorkbook.Path & "\Smart1.xlsx"

With Workbooks("Smart1.xlsx").Worksheets("Sheet1")
.Range("a2").Value = Name
.Range("B2").Value = PSFFAll
.Range("C2").Value = CLSFall
.Range("D2").Value = CLSWin
.Range("E2").Value = CLSEnd
.Range("F2").Value = WWRFall
.Range("G2").Value = WWRWin
.Range("H2").Value = WWREnd
.Range("I2").Value = DORFWin
.Range("J2").Value = DORFEnd
.Range("K2").Value = AccWin
.Range("L2").Value = AccEnd
End With

ActiveWorkbook.saveas FileName:=SavePath & "\" & fname
ActiveWorkbook.Close True
On Error Resume Next

Next C

End Sub

Answer 1

这只是第一个问题的答案。用它来检查文件是否存在。

Sub saveme()

    SavePath = "D:\folder"
    fname = "test.xls"
    fullsavepath = SavePath & "\" & fname

    On Error Resume Next
    If Dir(fullsavepath) <> "" Then
        Open fullsavepath For Binary Access Read Lock Read As #1: Close #1
    End If

    If Err.Number <> 0 Then

        If MsgBox("A file with the name '" & fname & "' is already open." & vbCrLf & _
            "Do you want to replace it?", vbYesNo + vbQuestion + vbDefaultButton2, _
            "Microsoft Excel") = vbYes Then

            Application.DisplayAlerts = False
            Workbooks(fname).Close savechanges:=False
            ActiveWorkbook.SaveAs Filename:=fullsavepath
            Application.DisplayAlerts = True
        End If

    Else
        ActiveWorkbook.SaveAs Filename:=fullsavepath
    End If

    Err.Clear

End Sub

重要的部分是：

If Dir(fullsavepath) <> "" Then
    Open fullsavepath For Binary Access Read Lock Read As #1: Close #1
End If

Answer 2

这是答案！感谢Tweedle！ Sub Smart1（） Dim src As Workbook Dim dst As Workbook SavePath = ActiveWorkbook.Path

Set src = ActiveWorkbook


For Each C In Range("Names1")


    i = C.Row


    Name = Cells(i, 44).Value
    PSFFAll = Cells(i, 45).Value
    CLSFall = Cells(i, 46).Value
    CLSWin = Cells(i, 47).Value
    CLSEnd = Cells(i, 48).Value
    WWRFall = Cells(i, 49).Value
    WWRWin = Cells(i, 50).Value
    WWREnd = Cells(i, 51).Value
    DORFWin = Cells(i, 52).Value
    DORFEnd = Cells(i, 53).Value
    AccWin = Cells(i, 54).Value
    AccEnd = Cells(i, 55).Value


    fname = Cells(i, 44).Value & ".xlsx"

    If Dir(SavePath & "\" & fname) = "" Then
        'Filename does not exist, then use template
        Set dst = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Smart1.xlsx")
    Else
        'File already exists, then use existing & update
        Set dst = Workbooks.Open(Filename:=SavePath & "\" & fname)
    End If

    With dst.Worksheets("Sheet1")
        .Range("a2").Value = Name
        .Range("B2").Value = PSFFAll
        .Range("C2").Value = CLSFall
        .Range("D2").Value = CLSWin
        .Range("E2").Value = CLSEnd
        .Range("F2").Value = WWRFall
        .Range("G2").Value = WWRWin
        .Range("H2").Value = WWREnd
        .Range("I2").Value = DORFWin
        .Range("J2").Value = DORFEnd
        .Range("K2").Value = AccWin
        .Range("L2").Value = AccEnd
    End With
    Application.DisplayAlerts = False
    dst.Close True, SavePath & "\" & fname
    Application.DisplayAlerts = True
    On Error Resume Next


Next C

End Sub

如何仅更新工作簿模板的Sheet1 ...？

2 个答案: