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

我想将此代码从写入同一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

---

谢谢

您可能想试试这样的东西：

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")

---

您可以这样做（请原谅任何不正确的语法，我手头没有excel，但您明白了）

---

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

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

子测试（）
将ws设置为工作表
暗rngData As范围
Dim数据单元作为范围
Dim arresults（）作为变量
Dim ResultIndex尽可能长
将strFolderPath设置为字符串
设置ws=图纸（“图纸1”）
设置rngData=ws.Range（“A2”，ws.Cells（Rows.Count，“A”）。End（xlUp））
如果rngData.Row<2，则退出Sub“无数据”
ReDim arrResults（1到rngData.Rows.Count，1到11）
strFolderPath=ActiveWorkbook.Path和Application.PathSeparator
对于rngData.Cells中的每个数据单元
ResultIndex=ResultIndex+1
选择大小写（Len（ws.Cells（DataCell.Row，“B”）.Text）>0）
大小写为True:arrResults（ResultIndex，1）=“&ws.Cells（DataCell.Row，“B”）.Text&”
其他情况：arrResults（ResultIndex，1）=“&ws.Cells（DataCell.Row，“A”）.Text&”
结束选择
arrResults（ResultIndex，2）=“&ws.Cells（DataCell.Row，“B”）.Text&”
arrResults（ResultIndex，3）=“动物/类型/”&DataCell.Text&“/option/an&&DataCell.Text&“\u co.png”
arrResults（ResultIndex，4）=“动物/”&DataCell.Text&“/option/an&&DataCell.Text&“&uCO2.png”
arrResults（ResultIndex，5）=“动物/”&DataCell.Text&“/shade/an&”和DataCell.Text&“\u shade.png”
arrResults（ResultIndex，6）=“动物/”&DataCell.Text&“/shade/an”&DataCell.Text&“\u shade2.png”
arrResults（ResultIndex，7）=“动物/”&DataCell.Text&“/shade/an&”&DataCell.Text&“\u shade.png”
arrResults（ResultIndex，8）=“动物/”&DataCell.Text&“/shade/an”&DataCell.Text&“\u shade2.png”
arrResults（ResultIndex，9）=“&ws.Cells（DataCell.Row，“C”）.Text&”
arrResults（ResultIndex，10）=“&ws.Cells（DataCell.Row，“D”）.Text&”
arresults（ResultIndex，11）=“&ws.Cells（DataCell.Row，“E”）.Text&”
下一个数据单元
'添加新工作表
与床单。添加
纸张（“纸张2”）。行（1）。复印范围（“A1”）
.Range（“A2”）.Resize（ResultIndex，UBound（arrResults，2））.Value=arrResults
“.UsedRange.EntireRow.AutoFit”如果需要，请取消对此行的注释
'移动将此工作表移动到其自己的工作OK
移动
'保存工作簿时，关闭DisplayAlerts将取消覆盖现有文件的提示
Application.DisplayAlerts=False
ActiveWorkbook.SaveAs strFolderPath&“destin.xls”，xlExcel8
Application.DisplayAlerts=True
以
设置ws=Nothing
设置rngData=Nothing
设置DataCell=Nothing
清除ARR结果
端接头

哦，是的。。。。别忘了保存它，正如Rob我在他的例子中提到的（必须加上我在写我的例子…几乎是同一种事情）Hi Code_Fedder，谢谢你的回复。我试过了，但由于某种原因它不会运行哪部分不起作用？（它没有进行语法测试，我现在正在工作中使用linux…所以现在只使用libra office，我可以在周末看一看。）嗨，Rob，谢谢你的回复。我照你说的做了，但出于某种原因，它创建了文档，但一直说它已经存在，但它没有，也没有从源excel文件中放入条目。这里是我做的sub test（）Dim book As Workbook Set book=Workbook.Add s1=“Sheet1”s2=“Sheet2”Set r=Sheets（s1）.范围（Sheets（s1）.单元格（2，1），Sheets（s1）.单元格（Sheets（s1）.范围（“A1”）.结束（xlDown）.行，1））计数=1，对于r book.Sheets（s2）中的每个c.单元格（Count+1，1）==“c.值&”book.Sheets（s2）.单元格（Count+1,2）=”和表（s1）.单元格（Count+1,2）.Value&”book.Sheets（s2）.Cells（Count+1,3）=“动物/”&c.Value&“/option/an_“&c.Value&“\u co.png”Count=Count+1 book.SaveAs（“destin.xlsx”）下一个c端Sub@Chuck我对这个答案进行了编辑，将原始工作簿保存到一个

orig

变量中。这是必要的，因为否则对

Sheets

的调用将在新工作簿中而不是原始工作簿中查找工作表。看看这是否更有意义。Tigeravatar这太神奇了，它可以工作太好了！谢谢！我有一个问题。对于新创建的文档，我想添加标题，那么如何添加以下内容：book.Sheets（s2）。Cells（1，1）=“Header 1”book.Sheets（s2）。Cells（1，2）=“Header 2”book.Sheets（s2）。Cells（1，3）=“Header 3”book.Sheets（s2）。Cells（1，4）=“Header 4”请参阅上面的评论。谢谢如果您已经在Sheet2中有了标题（我假设），那么获取标题就是此行的目的：

Sheets（“Sheet2”）.Rows（1）.Copy.Range（“A1”）

，但是，如果您需要在代码中手动添加标题，您可以使用类似这样的行：

.Range（“A1”）.Resize（，11）.Value=Array（“标题1”，“页眉2”，“页眉3”，等等。

事实上，我认为阅读第2页会很好，谢谢：）最后一件事。在源文件中，我有两列，我想创建一个if语句，表示-->如果A列在那里（表示输入了数字），但B列为空，则显示A列的值；如果A列在那里，B列在那里，则显示B列的值……我想逐行执行此操作。这有意义吗？

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