![](/img/trans.png)
[英]Email From Excel: RangetoHTML existing sheet instead of new workbook
[英]Writing to new workbook instead of sheet in existing workbook
我想將此代碼從寫入到同一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
謝謝
您可能想要嘗試這樣的事情:
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")
我將數據放入一個數組中,然后創建一個新工作表,輸出該數組並使用.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
你可以做這樣的事情(對不起,我沒有擅長的語法錯誤,但是你明白了)。
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.