| |
こんなかな？
ただ、B列はIDで日付はA列に成っているのですが？
Option Explicit
Public Sub Sample()
'出力するファイルの拡張子
Const cstrExten As String = ".xls"
Dim i As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngHeader As Range
Dim vntBookName As Variant
Dim dicIndex As Object
Dim strProm As String
'◆「抽出データ」の先頭セル位置を基準とする（先頭列の列見出し「日付」のセル位置）
Set rngList = Worksheets("Sheet1").Range("A1")
'「抽出データ」の表に就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'列見出し列数の取得
lngColumns = .Offset(, Columns.Count - _
.Column).End(xlToLeft).Column - .Column + 1
'列見出し範囲の取得
Set rngHeader = .Resize(, lngColumns)
End With
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'画面更新を停止
Application.ScreenUpdating = False
'Key列に就いて繰り返し
For i = 1 To lngRows
'データ列数の取得
With rngList
lngColumns = .Offset(i, Columns.Count - _
.Column).End(xlToLeft).Column - .Column + 1
'B列?の値取得(日付はA列ですが？)
' vntBookName = .Offset(i, 1).Value
'A列の日付値取得
vntBookName = Format(.Offset(i).Value, "yyyymmdd")
End With
With dicIndex
'出力Book名の取得
.Item(vntBookName) = .Item(vntBookName) + 1
'Book名の作成
vntBookName = ThisWorkbook.Path & "\" & vntBookName & "-" _
& .Item(vntBookName) & cstrExten
End With
'1Book分の転記
DataTransfer rngHeader, rngList.Offset(i).Resize(, lngColumns), vntBookName
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set dicIndex = Nothing
Set rngList = Nothing
Set rngHeader = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataTransfer(rngHeader As Range, _
rngOutput As Range, _
vntBookName As Variant)
' 1Book分の転記
'出力シートの出力位置
Const cstrTop As String = "A1"
Dim rngResult As Range
'Bookを追加してSheetのA1を基準とします
Set rngResult = Workbooks.Add.Worksheets(1).Range("A1")
With rngResult
'列見出しを出力
rngHeader.Copy Destination:=.Cells(1, 1)
'データを転記
rngOutput.Copy Destination:=.Offset(1)
'新規Bookを名前を付けて保存します
Application.DisplayAlerts = False
With .Parent.Parent
.SaveAs Filename:=vntBookName
'Excel2007の場合
' .SaveAs Filename:=vntBookName, FileFormat:=xlExcel8
.Close
End With
Application.DisplayAlerts = True
End With
Set rngResult = Nothing
End Sub
|
|
Hirofumi
- 09/5/28(木) 7:58 -
