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

我想将这个代码从写入到同一个Excel工作簿的工作表2中创build另一个名为destin.xls的工作簿并将所有信息转储到那里。

有什么build议么？

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

我将数据放入一个数组，然后创build一个新工作表，输出数组并使用.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 2

你可能想尝试这样的事情：

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