ブックを更新する

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 

ケースが作動し、マクロ削除されていませんあなたはそれを「SET」にしようとすると、すべてのシート名

がフィードバック

Answer 1

ありがとうございました関係なく、ワークブックオープンですか？ない場合は、そのように開く必要があります：

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

Answer 2

あなたはEnviron("temp")を使用して一時フォルダを見つけることができますが、あなたのコードから、私は、これはあなたが使用しているフォルダであるか分かりません。

このコードには、ブックが存在し、既に開いているかどうかを確認するための2つの機能があります。私が追加したいもう一つのビットは、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 3

私が最後に望んでいたコードを作ることができました。助けのための@Darren Bartrup・クックへ

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 

ありがとう：ここ は好奇心のためか、同じことを行うために探して、他の人のための答えです。