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保存为您想要的任何名称，如下所示： / p>

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

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

3 个答案: