1

我需要创建将 excel 行从单个工作表转换为新工作表的宏。

我有 3 行标题，后跟大量数据行。

我想将此表“部门”上的每一行放入自己的新表中（标题行除外）。在创建的每张新工作表上，我希望重复前 3 行（标题）并复制格式（如果可能），然后是“部门”工作表中的单个相应行。我还希望将新工作表命名为在 A 列中输入的值（即下例中的吸顶灯或壁灯）。

我没有宏观经验，所以我无法从以前的答案中获取代码并尝试将其应用于我的事业。谢谢您的帮助！

       A           B           C          D

  1. 部门模板//促销//快速链接//主横幅

  2. 在哪里找到 // 内容槽 // 类别 // 属性

  3. 空白 // 内容资产 // html // 主图

  4. 吸顶灯 // 值 // 值 // 值

  5. 壁灯 // 值 // 值 // 值

  6. 落地灯 // 值 // 值 // 值

转换为同一工作簿中在 3 个标题行之后有一行的新工作表：

新表名为：天花板灯

       A           B           C          D

  1. 部门模板//促销//快速链接//主横幅

  2. 在哪里找到 // 内容槽 // 类别 // 属性

  3. 空白 // 内容资产 // html // 主图

  4. 吸顶灯 // 值 // 值 // 值

新表名为：壁灯

       A           B           C          D

  1. 部门模板//促销//快速链接//主横幅

  2. 在哪里找到 // 内容槽 // 类别 // 属性

  3. 空白 // 内容资产 // html // 主图

  4. 壁灯 // 值 // 值 // 值

这是我到目前为止的代码......

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。

不知道如何解决？另外，有没有办法保留标题格式（列宽）？

4

1 回答 1

1

这是你正在尝试的吗？

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
于 2012-05-17T16:50:41.253 回答