写入新工作簿，而不是现有工作簿中的工作表

Question

我想将此代码从写入到同一excel工作簿的工作表2转换为创建另一个名为destin.xls的工作簿，并将所有信息转储到那里。

有什么建议么？

Sub test()
s1 = "Sheet1"
s2 = "Sheet2"
Set r = Sheets(s1).Range(Sheets(s1).Cells(2, 1), Sheets(s1).Cells(Sheets(s1).Range("A1").End(xlDown).Row, 1)) 
Count = 1
For Each c In r
    Sheets(s2).Cells(Count + 1, 1) = "" & c.Value & ""
    Sheets(s2).Cells(Count + 1, 2) = "" & Sheets(s1).Cells(Count + 1, 2).Value & ""
    Sheets(s2).Cells(Count + 1, 3) = "animals/type/" & c.Value & "/option/an_" & c.Value & "_co.png"
    Sheets(s2).Cells(Count + 1, 4) = "animals/" & c.Value & "/option/an_" & c.Value & "_co2.png"
    Sheets(s2).Cells(Count + 1, 5) = "animals/" & c.Value & "/shade/an_" & c.Value & "_shade.png"
    Sheets(s2).Cells(Count + 1, 6) = "animals/" & c.Value & "/shade/an_" & c.Value & "_shade2.png"
    Sheets(s2).Cells(Count + 1, 7) = "animals/" & c.Value & "/shade/an_" & c.Value & "_shade.png"
    Sheets(s2).Cells(Count + 1, 8) = "animals/" & c.Value & "/shade/an_" & c.Value & "_shade2.png"
    Sheets(s2).Cells(Count + 1, 9) = "" & Sheets(s1).Cells(Count + 1, 3).Value & ""
    Sheets(s2).Cells(Count + 1, 10) = "" & Sheets(s1).Cells(Count + 1, 4).Value & ""
    Sheets(s2).Cells(Count + 1, 11) = "" & Sheets(s1).Cells(Count + 1, 5).Value & ""
    Count = Count + 1
Next c

End Sub

谢谢

Answer 1

您可能想要尝试这样的事情：

Dim orig As Workbook
Set orig = ActiveWorkbook

Dim book As Workbook
Set book = Workbooks.Add

...
Set r = orig.Sheets(s1).Range(...)
...
book.Sheets(s2).Cells(...) = orig.Sheets(s1).Cells(...)
...

book.SaveAs("destin.xls")

Answer 2

我将数据放入一个数组中，然后创建一个新工作表，输出该数组并使用.Move将添加的工作表移动到其自己的工作簿中，然后将ActiveWorkook保存为所需的名称，如下所示：

Sub test()

    Dim ws As Worksheet
    Dim rngData As Range
    Dim DataCell As Range
    Dim arrResults() As Variant
    Dim ResultIndex As Long
    Dim strFolderPath As String

    Set ws = Sheets("Sheet1")
    Set rngData = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
    If rngData.Row < 2 Then Exit Sub    'No data

    ReDim arrResults(1 To rngData.Rows.Count, 1 To 11)
    strFolderPath = ActiveWorkbook.Path & Application.PathSeparator

    For Each DataCell In rngData.Cells
        ResultIndex = ResultIndex + 1
        Select Case (Len(ws.Cells(DataCell.Row, "B").Text) > 0)
            Case True:  arrResults(ResultIndex, 1) = "" & ws.Cells(DataCell.Row, "B").Text & ""
            Case Else:  arrResults(ResultIndex, 1) = "" & ws.Cells(DataCell.Row, "A").Text & ""
        End Select
        arrResults(ResultIndex, 2) = "" & ws.Cells(DataCell.Row, "B").Text & ""
        arrResults(ResultIndex, 3) = "animals/type/" & DataCell.Text & "/option/an_" & DataCell.Text & "_co.png"
        arrResults(ResultIndex, 4) = "animals/" & DataCell.Text & "/option/an_" & DataCell.Text & "_co2.png"
        arrResults(ResultIndex, 5) = "animals/" & DataCell.Text & "/shade/an_" & DataCell.Text & "_shade.png"
        arrResults(ResultIndex, 6) = "animals/" & DataCell.Text & "/shade/an_" & DataCell.Text & "_shade2.png"
        arrResults(ResultIndex, 7) = "animals/" & DataCell.Text & "/shade/an_" & DataCell.Text & "_shade.png"
        arrResults(ResultIndex, 8) = "animals/" & DataCell.Text & "/shade/an_" & DataCell.Text & "_shade2.png"
        arrResults(ResultIndex, 9) = "" & ws.Cells(DataCell.Row, "C").Text & ""
        arrResults(ResultIndex, 10) = "" & ws.Cells(DataCell.Row, "D").Text & ""
        arrResults(ResultIndex, 11) = "" & ws.Cells(DataCell.Row, "E").Text & ""
    Next DataCell

    'Add a new sheet
    With Sheets.Add
        Sheets("Sheet2").Rows(1).Copy .Range("A1")
        .Range("A2").Resize(ResultIndex, UBound(arrResults, 2)).Value = arrResults
        '.UsedRange.EntireRow.AutoFit   'Uncomment this line if desired

        'The .Move will move this sheet to its own workook
        .Move

        'Save the workbook, turning off DisplayAlerts will suppress prompt to override existing file
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs strFolderPath & "destin.xls", xlExcel8
        Application.DisplayAlerts = True
    End With

    Set ws = Nothing
    Set rngData = Nothing
    Set DataCell = Nothing
    Erase arrResults

End Sub

Answer 3

你可以做这样的事情（对不起，我没有擅长的语法错误，但是你明白了）。

Sub SourceToDest()
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet

    ' Setup Source
    Set wbSource = ThisWorkbook
    Set wsSource = wbSource.Sheets("Sheet1")

    'Setup Dest
    Set wbDest = Workbooks.Add
    Set wsDest = wbDest.Sheets("Sheet1")

    'Now just copy your values from the wsSource to the wsDest
    wsDest.Cells(Count + 1, 1) = "" & c.Value & ""
    'etc... as you where doing...

    'or copy directly from one sheet to another...
    wsDest.Cells(Count + 1, 1) = wsSource.Cells(Count + 1, 1)
End Sub