[[20230324135202]]　『vbaを用いてシートごとに自動転記する際にエラーａx（にこ）　ページの最後に飛ぶ

『vbaを用いてシートごとに自動転記する際にエラーが発生する。』（にこ）

vbaを用いてシートごとに自動転記する際にエラーが発生してしまいます。

プログラム９で

実行時エラー1004
この名前は既に使用されています。別の名前を入力してください。

といわれてしまいます。

このような場合、どうすればよろしいでしょうか。

'プログラム1｜プログラム開始
Sub CreateSheets()

    'プログラム2｜シート設定
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("データ")
    Set ws2 = ThisWorkbook.Worksheets("原紙")

    'プログラム3｜最終行を取得
    Dim cmax1 As Long
    cmax1 = ws1.Range("A65536").End(xlUp).Row

    'プログラム4｜「データ」シートをコピーして重複削除
    Dim ws3 As Worksheet
    ws1.Copy after:=ThisWorkbook.Worksheets(Worksheets.Count)
    Set ws3 = ThisWorkbook.ActiveSheet
    ws3.Range("A:Y").RemoveDuplicates Columns:=Array(1), Header:=xlYes

    'プログラム5｜プログラム4で重複削除したシートの最終行を取得
    Dim cmax2 As Long
    cmax2 = ws3.Range("A65536").End(xlUp).Row

    'プログラム6｜コピーしたシートを並び替え
    With ws3.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws3.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange ws2.Range("A2:Y" & cmax2)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'プログラム7｜重複削除、並び替えしたシートの2行目から最終行まで処理
    Dim i As Long
    For i = 2 To cmax2
        Dim sagaku As String
        sagaku = ws3.Range("A" & i).Value

        'プログラム8｜「原紙」シートをコピー
        Dim ws4 As Worksheet
        ws2.Copy after:=ThisWorkbook.Worksheets(Worksheets.Count)
        Set ws4 = ThisWorkbook.ActiveSheet

        'プログラム9｜コピーした「原紙」シートの名前を変更　←ここでエラーが発生します。
        ws4.Name = sagaku

        'プログラム10｜転記先の行数をn=2で初期化
        Dim n As Long: n = 2

        'プログラム11｜「データ」シートのA列がsagakuと一致したら転記
        Dim j As Long
        For j = 2 To cmax1
            If sagaku = ws1.Range("A" & j).Value Then
                ws4.Range("A" & n & ":Y" & n).Value = ws1.Range("A" & j & ":Y" & j).Value
                n = n + 1
            End If
        Next

        'プログラム12｜オブジェクト解放
        Set ws4 = Nothing
    Next

    'プログラム13｜重複削除、並び替えしたシートを削除
    Application.DisplayAlerts = False
    ws3.Delete
    Application.DisplayAlerts = True

    'プログラム14｜新しいエクセルファイルとして保存
    Dim newfilename As String
    newfilename = Format(Date, "yyyy-mm-dd") & "_" & ThisWorkbook.Name
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & newfilename
    Application.DisplayAlerts = True

'プログラム15｜プログラム終了
End Sub

＜使用 Excel：Excel2010、使用 OS：Windows11 ＞

 別の名前つけるしかないのでは・・・
 もしくは最初にsagakuシート削除するとか。
（稲葉） 2023/03/24(金) 14:05:28

すでに同名シートがある場合はどうしたいですか？
（火災報知器） 2023/03/24(金) 14:09:13

同名のシートがある場合は、先にできている同名のシートに入れたいです。

りんご　１個
みかん　５個
いちご　４個
りんご　６個　みたいなエクセルがある場合

VBAで
「りんご」シートを作って
りんご　１個
りんご　６個

「みかん」シートを作って
みかん　５個

「いちご」シートを作って
いちご　４個

といった感じにしたいです。
（にこ） 2023/03/24(金) 14:20:07

 >りんご　１個
 >みかん　５個
 >いちご　４個
 >りんご　６個　みたいなエクセルがある場合

 ↓のようなデータがあるシート（データシート）という意味ですか？

    |[A]   |[B] 
 [1]|品目  |個数
 [2]|りんご|１個
 [3]|みかん|５個
 [4]|いちご|４個
 [5]|りんご|６個

 ※原紙シートのA1セルに貼り付けます。
 Sub test()
     Dim ws1 As Worksheet, ws2 As Worksheet
     Dim i As Long, col As New Collection
     Set ws1 = Worksheets("データ")
     Set ws2 = Worksheets("原紙")
     On Error Resume Next
     For i = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
         col.Add ws1.Cells(i, "A"), ws1.Cells(i, "A")
     Next
     On Error GoTo 0
     For i = 1 To col.Count
         ws2.Copy After:=Worksheets(Worksheets.Count)
         ActiveSheet.Name = col(i)
         With ws1.Range("A1")
             .AutoFilter 1, col(i)
             .CurrentRegion.Copy Range("A1")
             .AutoFilter
         End With
     Next
 End Sub
（フォーキー） 2023/03/24(金) 14:41:12

        Dim ws4 As Worksheet
        'すでにsagaku名のシートがある場合ws4に代入
        On Error Resume Next
        Set ws4 = ThisWorkbook.Worksheets(sagaku)
        On Error GoTo 0
        '無い場合は
        If ws4 Is Nothing Then
            'プログラム8｜「原紙」シートをコピー
            ws2.Copy after:=ThisWorkbook.Worksheets(Worksheets.Count)
            Set ws4 = ThisWorkbook.ActiveSheet
            'プログラム9｜コピーした「原紙」シートの名前を変更　←ここでエラーが発生します。
            ws4.Name = sagaku
        Else
            ws4.Activate
        End If

このすぐ後のnの値など他にも修正する点はありますが、とりあえず。
（火災報知器） 2023/03/24(金) 14:54:32

回答いただきありがとうございます。

まだ試してませんが、上記のコードでやってみます。
ありがとうございます。
（にこ） 2023/03/24(金) 15:37:15

コメント返信：

[ 一覧(最新更新順) ]

[[20230324135202]] 『vbaを用いてシートごとに自動転記する際にエラーａx（にこ） ページの最後に飛ぶ

[[20230324135202]]　『vbaを用いてシートごとに自動転記する際にエラーａx（にこ）　ページの最後に飛ぶ