根據名稱將紙張合併到一張紙上

Question

我能夠在一張紙上編輯紙張，但是我想指出要複印的紙張。源文件可能有多個工作表名稱Delta Prices #因此，我想一旦找不到工作表名稱就結束循環。代碼是：

Option Explicit 
    Sub CreateDeltaReport() 

    Dim Newbook As Window 
    Dim wb As Workbook 
    Dim wb2 As Workbook 
    Dim ws As Worksheet 
    Dim vFile As Variant 
    Dim wkb As Workbook 
    Dim wb3 As Workbook 
    Dim s As Worksheets 


    Set wb = ThisWorkbook 
    vFile = Application.GetOpenFilename("All-Files,*.xl**", 1, "Select One File To Open", , False) 
    If TypeName(vFile) = "Boolean" Then Exit Sub 
    Workbooks.Open vFile 
    Set wb2 = ActiveWorkbook 

    wb2.Activate 

    Dim j As Integer 
    Dim h As Integer 

    On Error Resume Next 

    Sheets.Add After:=Sheets(Sheets.Count) 
    ActiveSheet.Name = "Raw Delta" 
    Sheets("Delta Prices 1").Activate 
    Range("A1").EntireRow.Select 
    Selection.Copy Destination:=Sheets("Raw Delta").Range("A1") 
    h = 1 
    For Each s In ActiveWorkbook.Sheets 
    If s.Name <> "Raw Delta" Then 
    Do 
    Application.GoTo Sheets("Delta Prices " & h).[a1] ' Sheet name is Delta Prices 1 
    Selection.CurrentRegion.Select 
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select 
    Selection.Copy Destination:=Sheets("Raw Delta").Cells(Rows.Count, 1).End(xlUp)(2) 
    h = h + 1         ' add 1 to h so the sheet name will be "Delta Prices 2 a" 
    Loop Until s.Name <> ("Delta Prices " & h) ' loop until Sheet name is not "Delta Prices #" 
    End If 
    Next 

    End Sub 

Answer 1

像這樣（未經）：

Sub CreateDeltaReport() 

    Dim wb2 As Workbook 
    Dim vFile As Variant 
    Dim wkb As Workbook 
    Dim s As Worksheet 
    Dim rd As Worksheet, rng As Range 
    Dim h As Integer 

    vFile = Application.GetOpenFilename("All-Files,*.xl**", 1, _ 
           "Select One File To Open", , False) 
    If vFile = False Then Exit Sub 

    Set wb2 = Workbooks.Open(vFile) 
    Set rd = wb2.Sheets.Add(After:=wb2.Sheets(wb2.Sheets.Count)) 
    rd.Name = "Raw Delta" 

    h = 1 
    Do 
     Set s = Nothing 
     On Error Resume Next 
     Set s = wb2.Worksheets("Delta Prices " & h) 
     On Error GoTo 0 

     If s Is Nothing Then 
      Exit Do 
     Else 
      With s.Range("A1").CurrentRegion 
       .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Copy _ 
          rd.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
      End With 
     End If 

     h = h + 1 
    Loop 

End Sub