Excel VBA質問箱 IV

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

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


13233 / 76734 ←次へ | 前へ→

【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

1 hits

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

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