Excel VBA質問箱 IV

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

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


36113 / 76732 ←次へ | 前へ→

【45803】Re:Do until について
回答  Kein  - 07/1/14(日) 21:39 -

引用なし
パスワード
   A列の各年度毎に新規シートを挿入し、それぞれの年度のデータをA1からコピーする。
ということがしたいのでしょーか ? いちおうそれを前提に組んでみました。

Sub Mk_NewSheets()
  Dim Cnt As Long, i As Long, Rw As Long
  Dim MyR As Range, C As Range
  Dim Ttl As Variant, Ary As Variant
 
  Application.ScreenUpdating = False
  Sheets("Sheet1").Activate: Ttl = Rows(1).Value
  With Range("A2", Range("A65536").End(xlUp)).Offset(, 1)
   .Formula = "=IF($A2<>$A3,$A2&"",""&COUNTIF($A$2:$A2,$A2))"
   .Value = .Value
   Set MyR = .SpecialCells(2, 2)
  End With
  Cnt = Worksheets.Count
  Worksheets.Add After:=Worksheets(Cnt), Count:=MyR.Count
  For Each C In MyR
   i = i + 1: Ary = Split(C.Value, ","): Rw = CLng(Ary(1))
   With Worksheets(Cnt + i)
     .Name = CStr(Ary(0))
     .Rows(1).Value = Ttl
     C.Offset(-1 * (Rw - 1)).Resize(Rw).EntireRow _
     .Copy .Range("A2")
     .Range("B:B").ClearContents
   End With
   Erase Ary
  Next
  MyR.EntireColumn.ClearContents: Set MyR = Nothing
  Application.ScreenUpdating = True
End Sub

1 hits

【45801】Do until について さくら 07/1/14(日) 20:37 質問
【45803】Re:Do until について Kein 07/1/14(日) 21:39 回答
【45809】Re:Do until について さくら 07/1/14(日) 22:30 質問
【45811】Re:Do until について Kein 07/1/14(日) 23:35 回答
【45815】Re:Do until について さくら 07/1/15(月) 5:46 お礼

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