问将筛选的数据复制到新的Excel工作簿，并在另存为对话框中进行提示

EN

Sub Transfer()

  Dim iRow As Long
  Dim iTotalRows As Long
  Dim iOutput As Long
  Dim wsMaster As Worksheet
  Dim wbNew As Workbook
  Dim wsOutput As Worksheet
  Dim sNewFile As String

 'the name of your source sheet
  Set wsMaster = ThisWorkbook.Worksheets("Master")

 'create your new target workbook 
  Set wbNew = Application.Workbooks.Add
  Set wsOutput = wbNew.Worksheets(1)
  wsOutput.Name = "Output"  'optional: name the output sheet

 'place your headings
  With wsOutput
     .Cells(1, 1) = "Date"
     .Cells(1, 2) = "Account"
     'etc
  End With

  iTotalRows = wsMaster.UsedRange.Rows.Count

 'assumes headings in row 1, so start scanning from row 2
  For iRow = 2 To iTotalRows

     'hard-coding the column positions here... not ideal but you can improve this bit
      If wsMaster.Cells(iRow, 6) = "Yes" And wsMaster.Cells(iRow, 7) = "" Then
         iOutput = iOutput + 2

         wsOutput.Cells(iOutput, 1) = wsMaster.Cells(iRow, 3) 'date
         wsOutput.Cells(iOutput + 1, 1) = wsMaster.Cells(iRow, 3) 'date again on the next row

         wsOutput.Cells(iOutput, 2) = wsMaster.Cells(iRow, 2) 'Account
         wsOutput.Cells(iOutput + 1, 2) = wsMaster.Cells(iRow, 2) 'Account again on the next row

        'etc

       'set pending flag
        wsMaster.Cells(iRow, 7) = "Pending"

      End If

  Next

 'prompt to save the new file: suggest a name with today's date encoded in it
  sNewFile = Application.GetSaveAsFilename("newFile" & Format(Now, "yymmdd") & ".xlsx")
  If sNewFile <> "" Then wbNew.SaveAs sNewFile

End Sub