1

あるワークブックの範囲から特定のテンプレートの Sheet1 にデータをコピーするこのコードがあります。(Sheet1 のデータは、テンプレート ファイルの 2 番目のシートに入力されます。) 各ファイルが作成され、範囲「names1」の名前が付けられます。

これは完全に機能しているように見えますが、他に 2 つのことを行う必要があります。

  • まず、ファイルが既にファイル名で作成されているかどうかを確認して確認する必要があります。作成されている場合は、上書きしないようにするか、保存するように求めます。
  • 第二に、そして最も重要なことは、既存のファイルをチェックし、ファイル内の他のシートの何も変更せずに、上記の情報で 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 に答える