ローカルファイル保存先
ファイル保存先
ファイル名
済 パス
Option Explicit
'sheet
Dim reSh As Worksheet
Dim wrSh As Worksheet
Dim rebk As Workbook
Dim wrbk As Workbook
'Cells
Dim wrRow As Long
Dim wrCol As Integer
Dim reRow As Long
Dim reCol As Integer
'file
Dim shName As String
Dim fileName As String
Dim filePath As String
Dim sourceFileName As String
Dim destFileName As String
'ファイルパスからモジュールを抽出しモジュールフォルダにテキストファイルを作成
Sub ChangMacroToTextList()
Dim localFolderPath As String
Dim destFolderPath As String
Dim keyFileName As String
Dim destFileName As String
Dim recFlg As Boolean
Set wrbk = ThisWorkbook
Set wrSh = wrbk.Worksheets("ファイルコピー")
wrCol = 2
wrRow = 1
localFolderPath = wrSh.Cells(wrRow + 1, wrCol)
destFolderPath = wrSh.Cells(wrRow + 2, wrCol)
keyFileName = wrSh.Cells(wrRow + 3, wrCol)
'フォルダ作成
Call CreateFolder(localFolderPath)
wrCol = 2
wrRow = 10
With wrSh
Do While .Cells(wrRow, wrCol) <> ""
destFileName = GetLocalTime
'ファイルコピー
recFlg = CopyFileWildCardD(.Cells(wrRow, wrCol), localFolderPath & "\" & argDestFileName, keyFileName)
If recFlg = True Then
.Cells(wrRow, wrCol - 1) = "済"
End If
wrRow = wrRow + 1
Loop
End With
'フォルダ作成
Call CreateFolder(localFolderPath)
'フォルダコピー
Call CopyFolderOne(localFolderPath, destFolderPath)
Set wrSh = Nothing
End Sub
'ファイルコピー
Function CopyFileWildCardD(argTargetFilePath As Variant, argDestFilePath As Variant, argKeyFileName As Variant) As Boolean
fileName = Dir(argTargetFilePath & "\" & argKeyFileName)
CopyFileWildCard = False
If fileName <> "" Then
Call CopyFile(argTargetFilePath & "\" & fileName, argDestFilePath)
CopyFileWildCard = True
End If
End Function
<mdl共有>
Option Explicit
'False/True
Public Const RETURN_FALSE = False
Public Const RETURN_TRUE = True
'GetLocalTime（Win32API）
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'// 64bit版
#If VBA7 And Win64 Then
Declare PtrSafe Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
'// 32bit版
#Else
Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
#End If
'sheet
Dim reSh As Worksheet
Dim wrSh As Worksheet
Dim rebk As Workbook
Dim wrbk As Workbook
'Cells
Dim wrRow As Long
Dim wrCol As Integer
Dim reRow As Long
Dim reCol As Integer
'file
Dim shName As String
Dim fileName As String
Dim filePath As String
Dim sourceFileName As String
Dim destFileName As String
Function GetLocalTime() As String
Dim sysTime As SYSTEMTIME
Dim setTime
'//現在日時取得
Call GetLocalTime(sysTime)
'//yyyymmdd_hhmmssffに整形
setTime = Format(sysTime.wYear, "0000")
setTime = setTime & Format(sysTime.wMonth, "00")
setTime = setTime & Format(sysTime.wDay, "00")
setTime = setTime & "_"
setTime = setTime & Format(sysTime.wHour, "00")
setTime = setTime & Format(sysTime.wMinute, "00")
setTime = setTime & Format(sysTime.wSecond, "00")
setTime = setTime & Format(sysTime.wMilliseconds, "00")
Debug.Print setTime
GetLocalTimeTest = CStr(setTime)
End Function
'ファイルコピー
Function CopyFileWildCard(argTargetFilePath As Variant, argDestFilePath As Variant, argKeyFileName As Variant) As Boolean
fileName = Dir(argTargetFilePath & "\" & argKeyFileName)
CopyFileWildCard = False
If fileName <> "" Then
Call CopyFile(argTargetFilePath & "\" & fileName, argDestFilePath)
CopyFileWildCard = True
End If
End Function
'ファイルコピー
Sub CopyFile(argTargetFilePath As Variant, argDestFilePath As Variant)
Dim objFso As New FileSystemObject
With objFso
'元ファイルが無い場合、EXIT
If (.FileExists(argTargetFilePath) = True) Then
Exit Sub
End If
'ファイルをコピー
.CopyFile argTargetFilePath, argDestFilePath
End With
End Sub
'新規フォルダ作成
Function CreateFolder(argFolderPath As String) As Boolean
On Error GoTo ERROR_1
Dim objFso As New FileSystemObject
'フォルダが存在しない
With objFso
If (.FolderExists(argFolderPath) = False) Then
'フォルダ作成
.CreateFolder (argFolderPath)
End If
End With
CreateFolder = RETURN_TRUE
Exit Function
ERROR_1:
CreateFolder = RETURN_FALSE
MsgBox "CreateFolderでエラーが発生しました エラー番号=" & Err.Number & Chr(13) & _
"エラーの内容は「" & Err.Description & "」です。"
End Function
'ファイルを一括でコピー
'引数：CopyFileAll(フォルダーパス & "\*.csv", フォルダーパス)
Sub CopyFileAll(argTargetWildFilePath As Variant, argDestFolderPath As Variant)
Dim objFso As New FileSystemObject
With objFso
'ファイルを一括でコピー
objFso.CopyFile argTargetWildFilePath, argDestFolderPath
End With
End Sub
'フォルダ コピー
'Call objFso.CopyFolder(argTargetPath, "D:\TipsCopy", True)
'フォルダ名を指定してコピー
'Call objFso.CopyFolder("D:\TipsFolder", "D:\ParentFolder\", True)
'同じフォルダ名でコピー (D:\ParentFolder\TipsFolder)
Sub CopyFolderOne(argTargetPath As Variant, argDestPath As Variant)
Dim objFso As New FileSystemObject
Dim targetPath As String
Dim destPath As String
targetPath = argTargetPath
destPath = argDestPath
With objFso
If (.FolderExists(destPath) = True) Then
If MsgBox("既存のフォルダを削除しますか？", vbOKCancel) = 1 Then
.DeleteFolder destPath
End If
End If
'フォルダ名を指定してコピー
.CopyFolder targetPath, destPath & "\"
End With
End Sub
