创建将Excel行从单个工作表转换为新工作表的宏 [英] create macro that will convert excel rows from single sheet to new sheets
问题描述
我需要创建将Excel行从单张转换为新张的宏.
I need to create macro that will convert excel rows from single sheet to new sheets.
我有3行标题,然后是大量数据行.
I have 3 Rows of headers followed by lots of rows of data.
我想将此工作表部门"中的每一行放入其自己的新工作表中(标题行除外).在创建的每个新工作表上,我希望重复前3行(标题)并复制格式(如果可能的话),然后从部门"工作表中选择相应的一行.我还希望将新工作表命名为在A列中输入的值(即下面示例中的吸顶灯或壁灯).
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).
我没有宏观经验,因此无法从以前的答案中获取代码并将其应用于我的事业.感谢您的帮助!
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
空白//内容资产//html//英雄形象
blank // content asset // html // hero image
天花灯//值//值//值
Ceiling Lights // value // value // value
壁灯//值//值//值
Wall Lights // value // value // value
落地灯//值//值//值
Floor Lights // value // value // value
转换为同一工作簿中的3个标题行之后只有一行的新工作表:
Converted to new sheets in the same workbook that have a single row after the 3 header rows:
新表名为:吸顶灯
A B C D
-
部门模板//促销//快速链接//主横幅
dept template // promos // quicklinks // main banner
//找到的位置//内容位置//类别//属性
where found // content slot // category // attributes
空白//内容资产//html//英雄形象
blank // content asset // html // hero image
天花灯//值//值//值
Ceiling Lights // value // value // value
新表名为:壁灯
A B C D
-
部门模板//促销//快速链接//主横幅
dept template // promos // quicklinks // main banner
//找到的位置//内容位置//类别//属性
where found // content slot // category // attributes
空白//内容资产//html//英雄形象
blank // content asset // html // hero image
壁灯//值//值//值
Wall Lights // value // value // value
这是我到目前为止的代码...
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
我可以根据代码顶部的A列中的单元格来创建和命名新工作表,但是当我尝试添加代码以将前三行(标题行)复制到每个新工作表中时,创建的工作表我得到以下错误9下标超出范围:Sheets(i).Cells(1、3).PasteSpecial.
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.
不确定如何解决? 另外,有没有办法保留标题格式(列宽)?
Not sure how to fix? Also, is there a way to preserve the header formatting (column widths)?
推荐答案
这是您要尝试的吗?
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
这篇关于创建将Excel行从单个工作表转换为新工作表的宏的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!