Excel VBA質問箱 IV

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

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


2279 / 13646 ツリー ←次へ | 前へ→

【69005】データの分割の仕方 総裁 11/5/7(土) 17:33 質問[未読]
【69006】Re:データの分割の仕方 UO3 11/5/7(土) 19:54 回答[未読]
【69007】Re:データの分割の仕方 UO3 11/5/7(土) 20:37 回答[未読]

【69005】データの分割の仕方
質問  総裁  - 11/5/7(土) 17:33 -

引用なし
パスワード
   このようなデータが全員のリスト.xlsというファイルにあります。

ID    A    B    C
1    98    93    44
1    58    19    74
1    25    16    95
1    29    37    55
1    48    78    34
2    77    78    86
2    88    6    14
3    69    89    74
3    60    65    40
3    27    39    18
3    10    10    57
3    39    70    25
4    91    95    19
4    83    68    18
:    :    :    :


いましたいのは、IDごとに

ID    A    B    C
1    98    93    44
1    58    19    74
1    25    16    95
1    29    37    55
1    48    78    34

の部分をID1.xlsとして全員のリスト.xlsが存在するフォルダに保存

ID    A    B    C
2    77    78    86
2    88    6    14

の部分をID2.xlsとして全員のリスト.xlsが存在するフォルダに保存
以下、ID3.xls…として全員のリスト.xlsが存在するフォルダに保存

したいのです。
このIDごとにデータを分割する部分の書き方が分かりません。
申し訳ありませんが、教えていただけませんか?
よろしくお願いいたします。

【69006】Re:データの分割の仕方
回答  UO3  - 11/5/7(土) 19:54 -

引用なし
パスワード
   ▼総裁 さん:

できあがりのブックのシートの列幅等が標準のものになっています。
必要であれば元シートの列幅を継承することも可能ですが。

全員リスト.xlsの標準モジュールに書きます。

Sub Sample()
  Dim wCol As Long
  Dim mRow As Long
  Dim v As Variant
  Dim x As Long
  Dim newSh As Worksheet
  
  Application.ScreenUpdating = False
  
  Set newSh = Sheets.Add
  
  With Sheets("Sheet1")
    mRow = .Range("A" & .Rows.Count).End(xlUp).Row
    wCol = .Cells.SpecialCells(xlCellTypeLastCell).Column + 2
    .Range("A1:A" & mRow).AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Cells(1, wCol), Unique:=True
    v = .Cells(1, wCol).CurrentRegion.Value
    .Cells(2, wCol).Resize(UBound(v, 1) - 1).ClearContents
    For x = 2 To UBound(v, 1)
      newSh.Cells.ClearContents
      .Cells(2, wCol).Value = v(x, 1)
      .Range("A1:D" & mRow).AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=.Cells(1, wCol).Resize(2), CopyToRange:=newSh.Range("A1"), _
      Unique:=False
      newSh.Copy
      ActiveWorkbook.SaveAs ThisWorkbook.Path & "\ID" & v(x, 1) & ".xls"
      ActiveWorkbook.Close
    Next
    
    .Cells(1, wCol).Resize(2).ClearContents
  End With
  
  Application.DisplayAlerts = False
  newSh.Delete
  Application.DisplayAlerts = True
  Set newSh = Nothing
  
  Application.ScreenUpdating = True
  
  MsgBox "処理が終了しました。"
    
End Sub

【69007】Re:データの分割の仕方
回答  UO3  - 11/5/7(土) 20:37 -

引用なし
パスワード
   ▼総裁 さん:

アップされたサンプルを見る限りIDの昇順に並んでいるようですので
こちらのほうが早いかも。
なお、新しく作るブックのシートの列幅等の書式は元シートを継承しています。

Sub Sample2()
  Dim v As Variant
  Dim newSh As Worksheet
  Dim i As Long, k As Long
  Dim w() As Variant
  Dim oldID As Variant, newID As Variant
  
  Application.ScreenUpdating = False
  
  Sheets.Add before:=Sheets(1)
  Set newSh = ActiveSheet
  newSh.Cells.ClearContents
  
  With Sheets("Sheet1")
  
    v = .Range("A2", .Range("A" & .Rows.Count).End(xlUp).Offset(1, 3))
    ReDim w(LBound(v, 1) To UBound(v, 1), 1 To 4)
    
    For i = LBound(v, 1) To UBound(v, 1)
      If i = LBound(v, 1) Then oldID = v(i, 1)
      newID = v(i, 1)
      If oldID <> newID Then
        newSh.Cells.ClearContents
        newSh.Range("A1:D1").Value = .Range("A1:D1").Value
        newSh.Range("A2").Resize(k, 4).Value = w
        newSh.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\ID" & oldID & ".xls"
        ActiveWorkbook.Close
        k = 0
        ReDim w(LBound(v, 1) To UBound(v, 1), 1 To 4)
      End If
      k = k + 1
      w(k, 1) = v(i, 1)
      w(k, 2) = v(i, 2)
      w(k, 3) = v(i, 3)
      w(k, 4) = v(i, 4)
      oldID = newID
    Next
    
  End With
  
  Application.DisplayAlerts = False
  newSh.Delete
  Application.DisplayAlerts = True
  Set newSh = Nothing
  
  Application.ScreenUpdating = True
  
  MsgBox "処理が終了しました。"
    
End Sub

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