サンプルソース
※指定したシートの指定した範囲から単一データの値を取得する関数
-[[http://kudoken.com]]
Function getConf(strKey As String)AsStringDim rngData As Range
Dim i As Integer
Set rngData = ThisWorkbook.Sheets("config").Range("rng_conf").CurrentRegion
For i = 1 To rngData.Rows.Count
If rngData.Cells(i, 1).Value = strKey Then
getConf = rngData.Cells(i, 2).Value
Exit For
End If
Next i
End Function
Sub test()
Dim strCurPath As String
Dim strTmpName As String
Dim strActTmpName As String
Dim strMakeFileName As String
Dim strSaveDirName As String
Dim wbkTmp As Workbook
Dim wbkMake As Workbook
Dim fName As String
'カレントディレクトリ指定
strCurPath = ThisWorkbook.Path
'保存先フォルダ取得
strSaveDirName = fncGetDirName()
If strSaveDirName <> "" Then
strTmpName = strCurPath & "\free.xlt"
strMakeFileName = strSaveDirName & "\make.xls"
'テンプレートファイルを開く
Workbooks.Open Filename:=strTmpName
'テンプレートオブジェクトセット
Set wbkTmp = ActiveWorkbook
'新規作成ファイルのセット
Set wbkMake = Workbooks.Add
wbkTmp.Sheets(1).Copy After:=wbkMake.Sheets(3)
ActiveSheet.Name = 1
Application.DisplayAlerts = False
'テンプレートファイルを閉じる
wbkTmp.Close
'不要なシートを削る
wbkMake.Sheets(1).Delete
wbkMake.Sheets(1).Delete
wbkMake.Sheets(1).Delete
'作成ファイルの保存
wbkMake.SaveAs Filename:=strMakeFileName
Application.DisplayAlerts = True
End If
End Sub
'************************************************
' 概要:フォルダ名を取得する
'************************************************
Function fncGetDirName() As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
fncGetDirName = .SelectedItems(1)
End If
End With
End Function
最終更新:2006年05月14日 00:13