寫入新的工作簿而不是現有工作簿中的工作表

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