1

我有这段代码可以将数据从一个工作簿中的范围复制到特定模板的 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
4

2 回答 2

0

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

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
于 2013-03-02T17:33:52.837 回答
0

这是答案！感谢特威德尔！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

结束子

于 2013-03-03T16:09:48.240 回答