1

Excel の行を単一のシートから新しいシートに変換するマクロを作成する必要があります。

ヘッダーが 3 行あり、その後に多数のデータ行が続きます。

このシート「部門」の各行を独自の新しいシートに配置したいと思います（ヘッダー行を除く）。作成された新しいシートごとに、上部の 3 行 (ヘッダー) が繰り返され、フォーマットがコピーされ (可能であれば)、次に "Dept" シートの対応する 1 行が必要です。また、新しいシートに列 A に入力された値の名前を付けたいと思います (つまり、以下の例の Ceiling Lights または Wall Lights)。

私はマクロの経験がないので、以前の回答からコードを取得して自分の目的に適用しようとしてもうまくいきません。助けてくれてありがとう！

       A           B           C          D

  1. 部門テンプレート // プロモーション // クイックリンク // メイン バナー

  2. 見つかった場所 // コンテンツ スロット // カテゴリ // 属性

  3. 空白 // コンテンツ アセット // html // ヒーロー画像

  4. シーリングライト // 値 // 値 // 値

  5. ウォールライト // 値 // 値 // 値

  6. フロアライト // 値 // 値 // 値

3 つのヘッダー行の後に 1 つの行がある同じブック内の新しいシートに変換されます。

新しいシート名: Ceiling Lights

       A           B           C          D

  1. 部門テンプレート // プロモーション // クイックリンク // メイン バナー

  2. 見つかった場所 // コンテンツ スロット // カテゴリ // 属性

  3. 空白 // コンテンツ アセット // html // ヒーロー画像

  4. シーリングライト // 値 // 値 // 値

新しいシート名: Wall Lights

       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 のセルに基づいて新しいシートを作成して名前を付けることができますが、最初の 3 行 (ヘッダー行) をこれらの新しく作成されたシートのそれぞれにコピーするコードを追加しようとすると、 Get Error 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 に答える