1

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

谢谢

4

3 回答 3

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")
于 2013-08-22T13:41:50.533 回答
1

我会将数据放入一个数组中，然后创建一个新工作表，输出该数组并使用 .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
于 2013-08-22T16:00:11.513 回答
0

你可以做这样的事情（请原谅我手头没有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
于 2013-08-22T13:53:46.447 回答