| |
▼マリモ さん：
元表のあるBookとは 別に マクロをおくBookを作ってください。
そのマクロBook の標準モジュールに コードを書きます。
たとえば以下。
元表をファイルダイアログを使って開き、そのシート1の表を
フィルタで(A,B,C列項目種類別に)別Bookに抽出コピーします。
（任意の月・日・番号 で抽出し 別Bookに転記するくり返しの部分は
読みやすさのために サブプロシージャに独立させてます）
'------------------------------------------------------ 標準モジュール
Option Explicit
Sub test1()
Dim srcFName
Dim orgBook As Workbook
Dim OrgSheet As Worksheet
Dim bookPath As String
Dim r As Range
'元表ファイルを開く
srcFName = Application.GetOpenFilename("元表Book,*.xls*")
If VarType(srcFName) = vbBoolean Then Exit Sub
Set orgBook = Workbooks.Open(srcFName) '元表のあるBook
bookPath = orgBook.Path & "\"
Set OrgSheet = orgBook.Worksheets(1) '元表のあるシート
Set r = OrgSheet.Cells(1).CurrentRegion
'元表のA,B,C列（月、日、番号）の種類リストを得る
Dim v, i As Long
Dim dic As Object 'リストオブジェクト
Set dic = CreateObject("Scripting.Dictionary")
v = r.Resize(, 3).Value '表のA,B,C列を配列に格納
For i = 2 To UBound(v) '重複をカットした抽出項目を作成
dic(v(i, 1) & "_" & v(i, 2) & "_" & v(i, 3)) = Empty
Next
'リストの順にフィルタをかけ、該当Bookに転記する
Dim ky
For Each ky In dic.Keys()
FilterCopy ky, r, bookPath
Next
orgBook.Close False
End Sub
'-----------------------------------------------------------
'元表rに ky項目で AutoFilterをかけ、抽出データを該当Bookに
'転記する
Private Sub FilterCopy(ky, ByVal r As Range, bookPath$)
Dim v
v = Split(ky, "_")
r.AutoFilter 1, Val(v(0)) 'A列を「月」で
r.AutoFilter 2, Val(v(1)) 'B列を「日」で
r.AutoFilter 3, Val(v(2)) 'C列を「番号」でFilter
'抽出行はタイトル行以外に一行以上ある
Dim bookName As String
Dim copyBook As Workbook
'転記先Bookはなければ新規作成する
bookName = bookPath & ky & "_○○○.xls"
On Error Resume Next
Set copyBook = Workbooks.Open(bookName)
On Error GoTo 0
If copyBook Is Nothing Then
Set copyBook = Workbooks.Add(xlWBATWorksheet)
copyBook.SaveAs bookName
End If
'------ 抽出データをコピー
r.Columns("D:F").Copy
copyBook.Worksheets(1).Range("H1").PasteSpecial Transpose:=True
copyBook.Save
copyBook.Close False
r.AutoFilter
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
