特定場所、ファイル名の変更
以下の様な他の方に組んで頂きました、動作段階でファイルの場所、ファイル名(開く、保存共）を聞いて来ますが、特定場所の特定ファイル名（disktop,ファイル名ABC)にするには、どこを変更すれば宜しいでしょうか？超初心者の為解りません教えて下さい。
Sub Sample()
Dim WB0 As Workbook
Dim WS0 As Worksheet
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WB2 As Workbook
Dim WS2 As Worksheet
Dim strFileName As String
Dim dic As Scripting.Dictionary
Dim vntData As Variant
Dim vntResult As Variant
Dim strKey As String
Dim vntRow As Long
Dim dic_i As Long
Dim i As Integer
Dim vntYYYY As Variant
Set WB0 = ThisWorkbook
strFileName = Application.GetOpenFilename("Excelファイル(*.xls),*.xls", , "クロス集計ファイルを選択してください")
If strFileName = "False" Then
MsgBox "ファイル選択がキャンセルされました。処理を中止します"
Exit Sub
End If
Do
vntYYYY = Application.InputBox("集計年度を数字4桁で指定してください", "年度指定", , , , , , 1)
If VarType(vntYYYY) = vbBoolean Then
MsgBox "年度指定がキャンセルされました。処理を中止します"
Exit Sub
End If
If IsNumeric(vntYYYY) And Len(vntYYYY) = 4 Then
Exit Do
Else
MsgBox "年度指定に誤りがあります。再入力してください " & vntYYYY
End If
Loop
'集計元ファイル
Set WB1 = Workbooks.Open(strFileName)
Set WS1 = WB1.Worksheets(1)
'集計先ファイル（新規追加）
Set WB2 = Workbooks.Add(xlWBATWorksheet)
Set WS2 = WB2.Worksheets(1)
'集計元データを配列に取得
vntData = WS1.Range("A1").CurrentRegion.Value
'集計先データの配列を確保（縦・集計元データ数、横・転記列数）
ReDim vntResult(1 To UBound(vntData), 1 To 18)
'Scripting.Dictionaryを生成
Set dic = New Scripting.Dictionary
'データ集計 集計キーはA列
For vntRow = 2 To UBound(vntData, 1)
'集計キーに存在しなかったら、キー追加
strKey = vntData(vntRow, 1)
If Not dic.Exists(strKey) Then
dic_i = dic_i + 1
dic(strKey) = dic_i
'初期値の設定
vntResult(dic_i, 1) = strKey
For i = 2 To 18
vntResult(dic_i, i) = 0
Next
End If
'集計結果を計算
If Val(vntData(vntRow, 2)) = Val(vntYYYY) - 2 Then
vntResult(dic(strKey), 2) = vntResult(dic(strKey), 2) + vntData(vntRow, 3)
End If
If Val(vntData(vntRow, 2)) = Val(vntYYYY) - 1 Then
vntResult(dic(strKey), 3) = vntResult(dic(strKey), 3) + vntData(vntRow, 3)
End If
If Val(vntData(vntRow, 2)) = Val(vntYYYY) Then
For i = 4 To 18
vntResult(dic(strKey), i) = vntResult(dic(strKey), i) + vntData(vntRow, i - 1)
Next
End If
Next
Set dic = Nothing
WB1.Close False
If dic_i > 0 Then
WS2.Range("A1").Resize(, 18).Value = _
Array("客先", Val(vntYYYY) - 2 & "年度", Val(vntYYYY) - 1 & "年度", Val(vntYYYY) & "年度", _
"上期計", "下期計", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
WS2.Range("A2").Resize(dic_i, 18).Value = vntResult
MsgBox "集計が完了しました"
Else
WB2.Close False
MsgBox "集計データがありませんでした"
End If
End Sub
お礼
BarcodMasterさん ありがとうございます。 想像通りに動きました。 【標準Module1】 Function GetFileName(OpenOrSaveFlg As Boolean, strFilter As String, _ strTitle As String, strDefaultPath As String) As String Dim returnValue As Integer Dim strFilePath As String strFilePath = strDefaultPath If strFilter = "" Then strFilter = "全てのファイル (*.*)|*.*" End If WizHook.Key = 51488399 'WIZHOOK有効 returnValue = WizHook.GetFileName( _ 0, "", strTitle, "", strFilePath, "", _ strFilter, _ 0, 0, 0, OpenOrSaveFlg _ ) WizHook.Key = 0 ' WizHook 無効 GetFileName = strFilePath End Function 【Fromのボタン】 Private Sub コマンド28_Click() Dim strFileName As String Dim ExpFileName As String ExpFileName = "表示材料_" & Format(Now(), "yyyymmdd") strFileName = GetFileName(False, "MicrosoftExcel ブック (*.xls)|*.xls", "", ExpFileName & ".xls") If Len(strFileName) = 0 Then 'キャンセルボタンが押されたときの処理を記述 MsgBox "キャンセルが押されました。" Else DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "T_WO_MAT", strFileName & ".xls", True End If End Sub