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

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

我会把数据放入一个数组，然后创建一个新的工作表，输出arr唉，并使用.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

你可以做财产以后这样的（请原谅任何不正确的语法我没有Excel出手，但你得到的想法）...

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