[英]Writing to new workbook instead of sheet in existing workbook
I want to convert this code from writing to sheet 2 of the same excel workbook to create another workbook called destin.xls and dump all the information there. 我想将此代码从写入到同一excel工作簿的工作表2转换为创建另一个名为destin.xls的工作簿,并将所有信息转储到那里。
Any suggestions? 有什么建议么?
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
Thanks 谢谢
You probably want to try something like this: 您可能想要尝试这样的事情:
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")
I would put the data into an array, then create a new sheet, output the array and use .Move to move the added sheet to its own workbook, and then save the ActiveWorkook as whatever name you want, like so: 我将数据放入一个数组中,然后创建一个新工作表,输出该数组并使用.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
You can do somthing like this (excuse any incorrect syntax I don't have excel to hand, but you get the idea) ... 你可以做这样的事情(对不起,我没有擅长的语法错误,但是你明白了)。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.