| |
「VBAド素人さん - 09/5/28(木) 3:48 -」の書き込みで
>新規ブックを作成する方法は分かるのですが、上記の抽出結果では
>8 列までしか記載してませんが､抽出結果は何列になるか分からない為
>最後の空白の列で終了するようにしたいです｡
「列」と「行」の言い方が間違っているのでは無いですか？
此れによって、コードが違うのですが？
今回は、上記が違っているとして書きます
また、「既定のフォーマット」在るシートは、
「既定のフォーマット」のBookの先頭シートとします
尚、「既定のフォーマット」のシートには、セルの書式設定も予め設定して置いて下さい
Option Explicit
Public Sub Sample_2()
'◆「元リスト」のデータ列数（A列〜D列）
Const clngColumns As Long = 4
'出力するファイルの拡張子
Const cstrExten As String = ".xls"
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim strModel As String
Dim vntPos As Variant
Dim vntItem As Variant
Dim vntList As Variant
Dim vntBookName As Variant
Dim dicIndex As Object
Dim strProm As String
'◆「元リスト」の先頭セル位置を基準とする（先頭列の列見出し「日付」のセル位置）
Set rngList = Worksheets("Sheet1").Range("A1")
'「既定のフォーマット」のBook名
strModel = ThisWorkbook.Path & "\" & "既定のフォーマット.xls"
If Dir(strModel) = "" Then
strProm = "既定のフォーマットのBookが有りません"
GoTo Wayout
End If
'「既定のフォーマット」書き込み位置
'日付、ID、メント、 結果の順で
vntPos = Array("B1", "B2", "C3", "D4")
'上記に対応する「元リスト」の列位置（A列を基準とする列Offset）
vntItem = Array(0, 1, 2, 3)
'「元リスト」の表に就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'画面更新を停止
Application.ScreenUpdating = False
'Key列に就いて繰り返し
For i = 1 To lngRows
'データ列数の取得
With rngList
'「元リスト」1行分データを配列に取得
vntList = .Offset(i).Resize(, clngColumns)
'B列?の値取得(日付はA列ですが？)
' vntBookName = vntList(1, 2)
'A列の日付値取得
vntBookName = Format(vntList(1, 1), "yyyymmdd")
End With
With dicIndex
'出力Book名の取得
.Item(vntBookName) = .Item(vntBookName) + 1
'Book名の作成
vntBookName = ThisWorkbook.Path & "\" & vntBookName & "-" _
& .Item(vntBookName) & cstrExten
'「既定のフォーマット」BookのCopy
FileCopy strModel, vntBookName
End With
'1Book分の転記
DataTransfer vntPos, vntItem, vntList, vntBookName
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set dicIndex = Nothing
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataTransfer(vntPos As Variant, _
vntItem As Variant, _
vntList As Variant, _
vntBookName As Variant)
' 1Book分の転記
Dim i As Long
Dim rngResult As Range
'転記するBookをOpenし、先頭シートのA1を基準セルとします
Set rngResult = Workbooks.Open(Filename:=vntBookName) _
.Worksheets(1).Range("A1")
With rngResult
'データを転記
For i = 0 To UBound(vntPos)
.Range(vntPos(i)).Value = vntList(1, vntItem(i) + 1)
Next i
'転記するBookの変更を保存します
.Parent.Parent.Close SaveChanges:=True
End With
Set rngResult = Nothing
End Sub
|
|
Hirofumi
- 09/5/29(金) 8:17 -
