※上記の広告は60日以上更新のないWIKIに表示されています。更新することで広告が下部へ移動します。

サンプルソース
※指定したシートの指定した範囲から単一データの値を取得する関数
-[[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