Excel VBA質問箱 IV

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

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


13234 / 76734 ←次へ | 前へ→

【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

1 hits

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

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