从Excel中获取某些信息，并在新工作簿中保存

Question

我需要帮助

我正在尝试从一本工作簿中获取额外的信息，并将其保存在一个新的书籍中 - 但我需要根据其参考文献进行分开。

我使用以下代码很棒，但它不是一个新的代码。

对VB-不好 - 因为我一段时间以前使用了它。

Option Explicit
Sub Main()
    Application.ScreenUpdating = False
    Dim rangeToSearch As Range
    Set rangeToSearch = Sheets(1).Range("C2:C" & Sheets(1).Range("C" & Rows.Count).End(xlUp).Row)
    Dim searchAmount As String
    searchAmount = InputBox("reference:")
    Dim cell As Range
    For Each cell In rangeToSearch
        If cell = CLng(searchAmount) Then
            Sheets(1).Rows(cell.Row & ":" & cell.Row).Copy
            Sheets(2).Rows( _
             Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1 & _
             ":" & _
             Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1 _
             ).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
        End If
    Next
Application.ScreenUpdating = True
End Sub

到目前为止，这效果很好，我只是不知道如何将其更改为新的工作簿而不是表。

请帮助

谢谢

Answer 1

解决方案＃1：将工作表保存为新工作簿

For-Loop之后，添加以下内容：

Sheets(2).Copy
Set wb2 = Workbooks(Workbooks.Count)
wb2.SaveAs "C:UsersYourUserDocumentstest.xls"l

，由于您使用了Option Explicit，因此您需要在功能顶部添加dim wb2 as Workbook

---

解决方案＃2：创建一个新的工作簿与

一起工作

Option Explicit
Sub Main()
    Application.ScreenUpdating = False
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Worksheets(1)
    Dim wb2 As Workbook
    Dim ws2 As Worksheet
    Set wb2 = Workbooks.Add
    Set ws2 = wb2.Worksheets(1)
    Dim rangeToSearch As Range
    Set rangeToSearch = ws1.Range("C2:C" & ws1.Range("C" & Rows.Count).End(xlUp).Row)
    Dim searchAmount As String
    searchAmount = InputBox("reference:")
    Dim cell As Range
    For Each cell In rangeToSearch
        If cell = CLng(searchAmount) Then
            ws1.Rows(cell.Row).Copy
            ws2.Rows(ws2.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial _
                Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End If
    Next
Application.ScreenUpdating = True
End Sub