ここから本文です

初心者です。VBAについてご相談させて下さい。 下記、構文ではシートに個人...

i_o********さん

2014/9/420:42:45

初心者です。VBAについてご相談させて下さい。


下記、構文ではシートに個人別のデータが作成されるのですが、余計なシート削除の部分で消してほしくないシートまで消されてしまいます。

残したいシートは"検索""貼付""その他"です。この"検索""貼付""その他"の右側から個人別データが作成されるようにするにはどうしたら良いのでしょうか?
下記構文からご指導頂けたら幸いです。



Sub 個人別データ作成()
'余計なシートを削除する。
i# = 1
Application.DisplayAlerts = False
Do While Worksheets.Count > 1
If Worksheets(i).Name = "検索" Then i = 2
Worksheets(i).Delete
Loop
Application.DisplayAlerts = True

For i = 2 To Worksheets("検索").Cells(65536, 2).End(xlUp).Row
j# = 1

'検索中の人のシートが既にできているかを判断する。
For Each sheet_name In Worksheets
If sheet_name.Name = Worksheets("検索").Cells(i, 2).Value Then
j = 2
Exit For
End If
Next
If j = 1 Then '検索中の人のシートがない場合、新規に作成する。
Worksheets.Add After:=Worksheets(Worksheets.Count)

Worksheets(Worksheets.Count).Name = Worksheets("検索").Cells(i, 2).Value
For j = 1 To 17
Worksheets(Worksheets.Count).Cells(1, j).Value = Worksheets("検索").Cells(1, j).Value
Next j
Worksheets(Worksheets.Count).Columns("G").NumberFormatLocal = "G/標準"
End If

'データコピー部
For j = 17 To 1 Step -1
Worksheets(Worksheets("検索").Cells(i, 2).Value). _
Cells(Worksheets(Worksheets("検索").Cells(i, 2).Value). _
Cells(65536, 1).End(xlUp).Row + 1, j).Value = Worksheets("検索").Cells(i, j).Value
Next j
Next i

'それぞれのシートの列幅を最適化します。
For Each sheet_name In Worksheets
sheet_name.Columns("A:Q").AutoFit
Next
End Sub

閲覧数:
67
回答数:
2

違反報告

ベストアンサーに選ばれた回答

jun********さん

2014/9/508:58:49

余計なシートを削除する部分を、以下のコードと差し替えてください。

Dim w As Worksheet

Application.DisplayAlerts = False
For Each w In Worksheets
If (w.Name <> "検索") And _
(w.Name <> "貼付") And _
(w.Name <> "その他") Then w.Delete
Next
Application.DisplayAlerts = True

新たに作成されるシートは、必ず右端に位置するようになっているので、こちらは大丈夫だと思います。

  • 質問者

    i_o********さん

    2014/9/512:30:17

    早速お応えいただき本当に感謝いたします。
    ありがとうございました!

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この回答は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜1件/1件中

30246kikuさん

2014/9/511:35:35

Excel では、For Each で削除できるようですが、私は戸惑ったものです。
例えば、コレクションの削除動作例として

Access2007 コントロールの削除
http://oshiete.goo.ne.jp/qa/6900623.html

ということで、どちらでも動けるように記述してみました。

   vA = Array("検索", "貼付", "その他")

部分には、残したいシートを列挙しておきます。
また、以降の記述も変更してみました。

ws.Cells(i, 1).Resize(, 17).Copy _
   wsN.Cells(Rows.Count, 1).End(xlUp).Offset(1)

と Copy を使ってみましたが、= が良ければ記述を逆にして

wsN.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 17) = _
   ws.Cells(i, 1).Resize(, 17)

とかにするとか・・・
※ 以下、未検証なので、おかしかったらごめんなさい


Sub Samp1()
   Dim ws As Worksheet, wsN As Worksheet
   Dim vA As Variant, v As Variant
   Dim i As Long

   vA = Array("検索", "貼付", "その他")

   Application.DisplayAlerts = False
   For i = Worksheets.Count To 1 Step -1
      For Each v In vA
         If (Worksheets(i).Name = v) Then Exit For
      Next
      If (IsEmpty(v)) Then Worksheets(i).Delete
   Next
   Application.DisplayAlerts = True

   Set ws = Worksheets("検索")
   For i = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
      v = ws.Cells(i, 2).Value
      For Each wsN In Worksheets
         If (wsN.Name = v) Then Exit For
      Next
      If (wsN Is Nothing) Then
         Set wsN = Worksheets.Add(After:=Worksheets(Worksheets.Count))
         With wsN
            .Name = v
            ws.Cells(1, 1).Resize(, 17).Copy .Cells(1, 1)
            .Columns("G").NumberFormatLocal = "G/標準"
         End With
      End If
      ws.Cells(i, 1).Resize(, 17).Copy _
         wsN.Cells(Rows.Count, 1).End(xlUp).Offset(1)
   Next
   Set ws = Nothing

   For Each wsN In Worksheets
      wsN.Columns("A:Q").AutoFit
   Next
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる