20180311②

Sub 転記()
'
' 転記 Macro
'

'

    Windows("管理台帳.xlsm").Activate
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "=[I18001.xlsx]Sheet1!R3C4"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "=[I18001.xlsx]Sheet1!R5C4"
    Range("E5").Select
    Range("D5").Select
    Windows("管理台帳.xlsm").Activate
    ActiveCell.FormulaR1C1 = "=[I18002.xlsx]Sheet1!R3C4"
    Range("E5").Select
    ActiveCell.FormulaR1C1 = "=[I18002.xlsx]Sheet1!R5C4"
    Range("E6").Select
    Windows("管理台帳.xlsm").Activate
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "=[I18003.xlsx]Sheet1!R3C4"
    Range("E6").Select
    ActiveCell.FormulaR1C1 = "=[I18003.xlsx]Sheet1!R5C4"
    Range("E7").Select
End Sub

 

20180311①

Option Explicit

'*********************************************************
 ' 　　指定フォルダ内のファイル名一覧を取得
'*********************************************************
Sub Get_FileName()
    Const cnsTitle = "ファイル名一覧取得"
    Const cnsDIR = "\*.*"
    Dim xlAPP As Application
    Dim strPath As String
    Dim strFilename As String
    Dim GYO As Long

    Set xlAPP = Application
    ' フォルダの場所を指定する
    strPath = "C:\Users\desktop\Desktop\新しいフォルダー"

    ' フォルダの存在確認 --- 必要な場合のみ記述 ---
    If Dir(strPath, vbDirectory) = "" Then
        MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
    Exit Sub
    End If

    ' 先頭のファイル名の取得
     strFilename = Dir(strPath & cnsDIR, vbNormal)
    ' ファイルが見つからなくなるまで繰り返す
    Do While strFilename <> ""
        ' 行を加算
         GYO = GYO + 1
        Cells(GYO + 3, 3).Value = strFilename
        ' 次のファイル名を取得
         strFilename = Dir()
    Loop
 End Sub
'-----------------<< End of Source >>------------------