Question

我创建了一个用于各种不同计算机的工作簿。有时我会添加功能，我想轻松更新它。这个想法是每当我有它的新版本时，我将它带到一台新计算机，保存在临时文件中并复制存储数据的表格。

基于答案我编辑了我的初稿:(我不知道两个工作簿需要同时打开）

Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim ws As Worksheet
Dim wb As Workbook
Dim wn As Workbook
Set wn = Workbooks("Reception")
Set wb = Workbooks("Reception2")

With wb
  .Sheets("Pass").Range("A1") = "flh"

  For Each ws In .Worksheets
    Select Case .Name
            Case "Formularios", "Coordenador", "LookupList", "Pass"
               'Do nothing
            Case Else
                ws.Delete
    End Select
  Next ws
End With

With wn
  For Each sh In .Worksheets
    Select Case .Name
        Case "Formularios", "Coordenador", "LookupList", "Pass"
        'Do nothing
        Case Else
            sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    End Select
  Next sh
End With

End Sub

案例暂时无效，宏无论名称

都会删除每张纸

谢谢大家的反馈

Answer 1

您可以使用Environ("temp")找到临时文件夹，但是从您的代码中我不确定这是您正在使用的文件夹。

此代码有几个函数可以检查工作簿是否存在且是否已打开。我要添加的另一部分代码是禁用Reception.xlsm中的任何代码在打开时触发。

Public Sub MyProcedure()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim wn As Workbook

    Dim Rec1Path As String
    Dim Rec2Path As String

    Rec1Path = "c:\save\Reception.xlsm"
    Rec2Path = "c:\temp\Reception2.xlsm"

    'Open or set a reference to Reception.xlsm.
    If WorkBookExists(Rec1Path) Then
        If WorkBookIsOpen(Rec1Path) Then
            'Don't need path for open workbook, just name.
            'InStrRev finds last occurrence of "\" (same as InStr, but in Reverse).
            Set wn = Workbooks(Mid(Rec1Path, InStrRev(Rec1Path, "\") + 1))
        Else
            Set wn = Workbooks.Open(Rec1Path)
        End If
    End If

    'Open or set a reference to Reception2.xlsm.
    If WorkBookExists(Rec2Path) Then
        If WorkBookIsOpen(Rec2Path) Then
            Set wb = Workbooks(Mid(Rec2Path, InStrRev(Rec2Path, "\") + 1))
        Else
            Set wb = Workbooks.Open(Rec2Path)
        End If
    End If

    With wb
        .Worksheets("Pass").Range("A1") = "flh"

        For Each ws In .Worksheets
            Select Case .Name
                Case "Formularios", "Coordenador", "LookupList", "Pass"
                    'Do nothing
                Case Else
                    'You don't really need the count of worksheets if you can guarantee
                    'you're not going to try and delete the last remaining sheet.
                    If .Worksheets.Count > 1 Then
                        Application.DisplayAlerts = False
                        ws.Delete
                        Application.DisplayAlerts = True
                    End If
            End Select
        Next ws
    End With

    With wn
        'Re-using the ws variable.
        For Each ws In .Worksheets
            Select Case .Name
                Case "Formularios", "Coordenador", "LookupList", "Pass"
                    'Do nothing
                Case Else
                    ws.Copy After:=wb.Sheets(wb.Sheets.Count)
            End Select
        Next ws
    End With

End Sub

Public Function WorkBookExists(sPath As String) As Boolean
    WorkBookExists = Dir(sPath) <> ""
End Function

Public Function WorkBookIsOpen(FullFilePath As String) As Boolean

    Dim ff As Long

    On Error Resume Next

    ff = FreeFile()
    Open FullFilePath For Input Lock Read As #ff
    Close ff
    WorkBookIsOpen = (Err.Number <> 0)

    On Error GoTo 0

End Function

Answer 2

当您尝试设置＆＃39;工作簿是否打开？它？如果没有，您将需要打开它：

Dim wb As Workbook
Set wb = Workbooks.Open("c:\temp\Reception.xlsm")

Answer 3

通过更多的谷歌搜索，我能够制作出我想要的代码。以下是好奇或其他想要做同样事情的人的答案：

Private Sub CommandButton1_Click() 
Dim sh As Worksheet
Dim ws As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim j As Long
Dim Rng As Range
Dim wb As Workbook
Dim wn As Workbook
Set wn = Workbooks("Reception")
Set wb = Workbooks("Reception2")

With wb
  .Sheets("Pass").Range("A1") = "flh"

  For Each ws In .Worksheets
    Select Case ws.Name
            Case "Formularios"
                'Do nothing
            Case "Coordenador"
                'Do nothing
            Case "LookupList"
                'Do nothing
            Case "Pass"
                'Do nothing
            Case Else
                 With ws
                    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    Set Rng = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
                    Rng.ClearContents
                End With
    End Select
  Next ws
End With

With wn
  For Each sh In .Worksheets
    Select Case sh.Name
            Case "Formularios"
                'Do nothing
            Case "Coordenador"
                'Do nothing
            Case "LookupList"
                'Do nothing
            Case "Pass"
                'Do nothing
            Case Else
                For j = 1 To wb.Sheets.Count
                    If sh.Name = wb.Worksheets(j).Name Then
                        On Error Resume Next
                            sh.Range("A:J").Copy wb.Worksheets(j).Range("A1")
                    End If
                Next j
    End Select
  Next sh
End With
  Application.CutCopyMode = False
End Sub

感谢@Darren Bartrup-Cook的帮助。

更新我的工作簿

3 个答案: