vba 创建将excel行从单个工作表转换为新工作表的宏
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/10627939/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
create macro that will convert excel rows from single sheet to new sheets
提问by user1399767
I need to create macro that will convert excel rows from single sheet to new sheets.
我需要创建将excel行从单个工作表转换为新工作表的宏。
I have 3 Rows of headers followed by lots of rows of data.
我有 3 行标题，后跟很多行数据。
I would like to place each row on this sheet "Dept" into new sheets of their own (with the exception of the header rows). On each new sheet created, I would like the top 3 rows (the headers) repeated and formatting copied (if possible), then the single corresponding row from the "Dept" sheet. I would also like the new sheets to be named the value entered in column A (i.e. Ceiling Lights or Wall Lights from the example below).
我想将此工作表“Dept”上的每一行放入他们自己的新工作表中（标题行除外）。在创建的每个新工作表上，我希望重复前 3 行（标题）并复制格式（如果可能），然后是“部门”工作表中的单个相应行。我还希望将新工作表命名为 A 列中输入的值（即以下示例中的天花板灯或壁灯）。
I have no macro experience, so I'm having trouble taking code from previous answers and trying to apply it to my cause. Thanks for the help!
我没有宏观经验，所以我无法从以前的答案中获取代码并将其应用于我的事业。谢谢您的帮助！
A B C D
dept template // promos // quicklinks // main banner
where found // content slot // category // attributes
blank // content asset // html // hero image
Ceiling Lights // value // value // value
Wall Lights // value // value // value
Floor Lights // value // value // value
部门模板 // 促销 // 快速链接 // 主横幅
where found // 内容槽 // 类别 // 属性
空白 // 内容资产 // html // 英雄图片
吸顶灯 // 值 // 值 // 值
壁灯 // 值 // 值 // 值
落地灯 // 值 // 值 // 值
Converted to new sheets in the same workbook that have a single row after the 3 header rows:
转换为同一工作簿中的新工作表，在 3 个标题行之后有一行：
new sheet named: Ceiling Lights
新工作表命名为：天花板灯
A B C D
dept template // promos // quicklinks // main banner
where found // content slot // category // attributes
blank // content asset // html // hero image
Ceiling Lights // value // value // value
部门模板 // 促销 // 快速链接 // 主横幅
where found // 内容槽 // 类别 // 属性
空白 // 内容资产 // html // 英雄图片
吸顶灯 // 值 // 值 // 值
new sheet named: Wall Lights
新表命名：壁灯
A B C D
dept template // promos // quicklinks // main banner
where found // content slot // category // attributes
blank // content asset // html // hero image
Wall Lights // value // value // value
部门模板 // 促销 // 快速链接 // 主横幅
where found // 内容槽 // 类别 // 属性
空白 // 内容资产 // html // 英雄图片
壁灯 // 值 // 值 // 值
Here's the code I have so far...
这是我到目前为止的代码......
Sub Addsheets()
Dim cell As Range
Dim b As String
Dim e As String
Dim s As Integer
Sheets("Dept").Select
a = "a4"
e = Range(a).End(xlDown).Address 'get's address of the last used cell
'loops through cells,creating new sheets and renaming them based on the cell value
For Each cell In Range(a, e)
s = Sheets.Count
Sheets.Add After:=Sheets(s)
Sheets(s + 1).Name = cell.Value
Next cell
Application.CutCopyMode = True
Dim Counter As Long, i As Long
Counter = Sheets.Count
For i = 1 To Counter
Sheets("Dept").Cells(1, 3).EntireRow.Copy
Sheets(i).Cells(1, 3).PasteSpecial
Next i
Application.CutCopyMode = False
End Sub
I can get the new sheets to create and name based on the cells in column A with the top portion of code, but when I tried adding code to have the first three rows (the header rows) copy to each of these newly created sheets I get Error 9 Subscript out of range for: Sheets(i).Cells(1, 3).PasteSpecial.
我可以根据代码顶部的 A 列中的单元格创建和命名新工作表，但是当我尝试添加代码以将前三行（标题行）复制到这些新创建的工作表中的每一个时，我获取错误 9 下标超出范围：Sheets(i).Cells(1, 3).PasteSpecial。
Not sure how to fix? Also, is there a way to preserve the header formatting (column widths)?
不确定如何修复？另外，有没有办法保留标题格式（列宽）？
回答by Siddharth Rout
Is this what you are trying?
这是你正在尝试的吗？
Option Explicit
Sub Sample()
Dim ws As Worksheet, tmpSht As Worksheet
Dim LastRow As Long, i As Long, j As Long
'~~> Change Sheet1 to the sheet which has all the data
Set ws = Sheets("Sheet1")
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
If LastRow < 4 Then Exit Sub
For i = 4 To LastRow
If DoesSheetExist(.Range("A" & i).Value) Then
Set tmpSht = Sheets(.Range("A" & i).Value)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = .Range("A" & i).Value
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(ws)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
