Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


30181 / 76732 ←次へ | 前へ→

【51820】Re:同じ内容のセルを転記するには
発言  じゅんじゅん  - 07/10/5(金) 22:55 -

引用なし
パスワード
   ▼mame さん:
>▼じゅんじゅん さん:
>>▼mame さん:
>返信ありがとうございます。
>うーん・・・
>どういえばいいんでしょうか・・・・
>
>イメージとしては、社名、請求額、請求書番号などがダーッと
>書かれたリストがあって、各社ごとに分けてシートを作りたいって感じです。
>社名は決まってなく毎回違いますので、コード内に入れ込む事が
>難しいと思いまして・・・・。
>
>説明がヘタクソですみません。。。。

Sheet1にデータがあって、A列(1行目は項目、2行目以下に社名)のデータ
毎にシート名(社名)を作成し、そのシートに社名毎のデータを転記する。
(同一のシート名が存在していたら、強制削除する)

Sub Test()
   Dim Dic As Object
   Dim key As Variant
   Dim sh1 As Worksheet
   Dim sh2 As Worksheet
   Dim Csh As Worksheet
   Dim r As Range

Application.ScreenUpdating = False

Set sh1 = Worksheets("Sheet1")
Set Dic = CreateObject("Scripting.Dictionary")

With sh1
   For Each r In .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp))
     Dic(r.Value) = Empty
   Next
End With

For Each key In Dic.keys
   For Each Csh In Worksheets
     If key = Csh.Name Then
      Application.DisplayAlerts = False
      Csh.Delete
      Application.DisplayAlerts = True
     End If
   Next

   Worksheets.Add After:=Worksheets(Worksheets.Count)
   ActiveSheet.Name = key
   Set sh2 = Worksheets(key)

   With sh1
      .Range("A1").AutoFilter Field:=1, Criteria1:=key
      .Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("A1")
      .AutoFilterMode = False
   End With

Next

Set Dic = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Application.ScreenUpdating = True
End Sub

こう言った事でしょうか?
1 hits

【51816】同じ内容のセルを転記するには mame 07/10/5(金) 17:30 質問
【51817】Re:同じ内容のセルを転記するには じゅんじゅん 07/10/5(金) 18:26 発言
【51818】Re:同じ内容のセルを転記するには mame 07/10/5(金) 22:02 発言
【51820】Re:同じ内容のセルを転記するには じゅんじゅん 07/10/5(金) 22:55 発言
【51821】Re:同じ内容のセルを転記するには じゅんじゅん 07/10/5(金) 23:07 発言
【51836】Re:同じ内容のセルを転記するには mame 07/10/6(土) 21:15 発言
【51838】Re:同じ内容のセルを転記するには じゅんじゅん 07/10/6(土) 21:53 発言
【51893】Re:同じ内容のセルを転記するには mame 07/10/9(火) 20:19 お礼

30181 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free