teacup. [ 掲示板 ] [ 掲示板作成 ] [ 有料掲示板 ] [ ブログ ]

 投稿者
  題名
  内容 入力補助 youtubeの<IFRAME>タグが利用可能です。(詳細)
    
 URL
[ ケータイで使う ] [ BBSティッカー ] [ 書込み通知 ] [ 検索 ]


フォルダ一覧をcsvに出力

 投稿者:(^・(O_O)・^)  投稿日:2016年11月26日(土)18時20分20秒
  Option Explicit

Dim objFSO
Dim objFile

Dim vFol_name
Dim vFol, vFol_sub
Dim vMsg
Dim cnt

'■フォルダ一覧の取得

'フォルダのオブジェクトを取得
vFol_name = "C:\Windows"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set vFol = objFSO.GetFolder(vFol_name)

'ファイル名の取得
For Each vFol_sub In vFol.SubFolders
   cnt = cnt + 1
   If cnt = 1 Then
      vMsg = vFol_sub.Name
   Else
      vMsg = vMsg & vbcrlf & vFol_sub.Name
   End If
Next

'WScript.Echo vFol_name & " 内のフォルダ一覧" & vbcrlf & vMsg

Set vFol_sub = Nothing



'■CSVに出力

Set objFile = objFSO.OpenTextFile("D:\vbs\vbs.csv", 2, True)

If Err.Number > 0 Then
    WScript.Echo "Open Error"
Else
    objFile.WriteLine vMsg
End If

objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
 
 

ファイルの一括起動

 投稿者:(^・(O_O)・^)  投稿日:2016年11月26日(土)18時18分36秒
  option explicit

'■変数の設定
Dim objShell
Dim vFol
Dim objApp


'エラーを無視する(フォルダが存在しないとき)
On Error Resume Next

'■アプリ起動

Set objShell = WScript.CreateObject("WScript.Shell")

'ソフトの起動
objShell.Run """C:\Program Files (x86)\Mozilla Firefox\firefox.exe""" 'Firefox
objShell.Run """C:\Program Files (x86)\Skype\Phone\Skype.exe""" 'Skype



'■フォルダを開く

vFol = "□フォルダパス"
Set objShell = WScript.CreateObject("Shell.Application")

If Err.Number = 0 Then
  objShell.Explore vFol
End If

Set objShell = Nothing



'■Excell起動

Set objApp = CreateObject("Excel.Application")

If objApp Is Nothing Then
Else

  'Excel表示(Excelが起動するまで3秒待機)
  objApp.Application.visible = True
  WScript.Sleep(3000)

  'Excelファイルを起動
  objApp.Application.Workbooks.Open("□Excelファイルパス1")
  objApp.Application.Workbooks.Open("□Excelファイルパス2")

  Set objApp = Nothing

End If



'Msgbox "完了"
 

フォルダ内のフォルダ一覧を取得する

 投稿者:(^・(O_O)・^)  投稿日:2016年11月26日(土)18時15分23秒
  Option Explicit

Dim objFileSys
Dim vFol_name
Dim vFol, vFol_sub
Dim vMsg

vFol_name = "C:\Windows"

'フォルダのオブジェクトを取得
Set objFileSys = CreateObject("Scripting.FileSystemObject")
Set vFol = objFileSys.GetFolder(vFol_name)

'ファイル名の取得
For Each vFol_sub In vFol.SubFolders
    vMsg = vMsg & vbcrlf & vFol_sub.Name
Next

WScript.Echo vFol_name & " 内のフォルダ一覧" & vbcrlf & vMsg

Set vFol_sub = Nothing
Set objFileSys = Nothing
 

珈琲

 投稿者:(^・(O_O)・^)  投稿日:2016年11月20日(日)10時49分56秒
  ベンチ コーヒー
https://tabelog.com/chiba/A1201/A120105/12036035/dtlmap/
Kope (コペ)
https://tabelog.com/chiba/A1201/A120105/12001075/

イイジマ コーヒー (iijima coffee) :八千代台
https://tabelog.com/chiba/A1202/A120204/12033981/
MOKICHI珈琲 (モキチコーヒー) :八柱
https://tabelog.com/chiba/A1203/A120302/12021497/
MOKICHI珈琲 (モキチコーヒー) :二和向台駅
https://tabelog.com/chiba/A1202/A120201/12001109/dtlrvwlst/7652661/



 

VBS

 投稿者:(^・(O_O)・^)  投稿日:2016年10月 4日(火)01時27分45秒
  VBScript Tips
http://www.whitire.com/vbs/

WSH@Workshop - WSHのサンプル集&リファレンス
http://wsh.style-mods.net/

WMI Sample ~ VBS を 使用した WMI サンプル集 ~
http://www.wmifun.net/sample/


●WSH -VBScript- サンプル集 - NAVER まとめ
http://matome.naver.jp/odai/2146690141871032301
 

VBA セルの条件付き書式を取得する

 投稿者:(^・(O_O)・^)  投稿日:2016年 4月11日(月)01時32分58秒
  '    http://www.tipsfound.com/vba/07019
'    buf = Range("A2").FormatConditions(1).Formula1
    buf = Range("A2").FormatConditions(1).Type
    MsgBox buf
    buf = Range("A2").FormatConditions(1).Formula2
    MsgBox buf

    buf = Range("A1").FormatConditions(1).Formula1
    Cells(1, 1) = "'" & buf
 

y_他_15-1225

 投稿者:(^・(O_O)・^)  投稿日:2016年 2月12日(金)01時32分19秒
  y_他_0425

Function y_その他()

'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ SendKeys
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    'http://officetanaka.net/excel/vba/statement/SendKeys.htm

'    SendKeys(Keys, Wait)
'
'Keys:       アプリケーションに送るキーまたはキーの組み合わせを、 文字列で指定
'Wait:       省略可能です。Trueを指定すると、送られたキーが処理されてから、
'            マクロに制御が戻ります。この引数でFalseを指定するか省略すると、
'            キーの処理が済むのを待たずにマクロの実行が続けられます。

' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'    SendKeys(Keys, Wait)
'    SendKeys "文字"
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    'abc "abc"
    'A×10                      "{A 10}"
    '[Ctrl]                     "^"
    '[Shift]                    "+"
    '[Alt]                      "%"
    '
    '[Ctrl] + c                 "^c"
    '{[Shift] + (a)}→b     "+ab"
    '{[Shift] + (a→b)}     "+(ab)"
    '[Alt] + f → u             "%fu"
    '
    '[↑]                       "{UP}"
    '[↓]                       "{DOWN}"
    '[←]                       "{LEFT} "
    '[→]                       "{RIGHT}"
    '[↑]×5回                  "{UP 5}"
    '
    '[Enter]                    "{ENTER}"
    '[Delete]                   "{DELETE}"
    '[Alt]+[F4]                 "%{F4}"
    '[HOME]                     "{HOME} "
    '[Tab]                      "{TAB}"
    '[Esc]                      "{ESC}"
    '[Page Down]                "{PGDN} "
    '[Page Up]                  "{PGUP}"
    '[F1 ~ F15]                "{F1} ~ {F15} "
    '
    '[Caps Lock]                "{CAPSLOCK} "
    '[Clear]                    "{CLEAR} "
    '[Help]                     "{HELP} "
    '[Insert]                   "{INSERT} "
    '[Num Lock]                 "{NUMLOCK} "
    '[Return]                   "{RETURN}"
    '[Scroll Lock]              "{SCROLLLOCK}"
    '[スペース] ‥[Shift]+[;]   "+;"
    '[BackSpace]                "{BACKSPACE}"

    '●英文字入力
    If IMEStatus <> vbIMEModeOff Then
         SendKeys "{kanji}"
    End If
    '●カナ入力
    If IMEStatus <> vbIMEModeHiragana Then
        SendKeys "{KANA}"
    End If

'●Sleepを使うプロシージャで定義する
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
#End If

    vTime = 11
    Application.Wait Now + TimeValue("0:00:" & vTime)

'     Sleep (10)         'マクロの処理を指定時間だけ停止。1000で1秒

'タイミングによっては、マクロを停止させるESCキー入力と誤判断され処理が中断されるので
'前もって、ESCキーのキャンセル処理を受け付けないようにしておく

    Application.EnableCancelKey = xlDisabled
    SendKeys ".......", True
    SendKeys "{ESC}"


'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ ショートカットキー
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━


    '[Alt]+[F3]キーにMacro1を設定
    Application.OnKey "^j", "Macro1"
    Application.OnKey "%{F3}"

    'OnKeyメソッドで設定したショートカットキーを解除
    Application.OnKey "^j"
    Application.OnKey "%{F3}"

    '設定したショートカットキーを解除(ShortcutKeyに「""」を指定)
    Application.MacroOptions Macro:="Macro1", ShortcutKey:=""

    '[F3] キーに設定
    Application.OnKey "{F3}", "Macro1"

'    Sub ショートカット_設定()
'
'        '[ALT]+[F3]
'        Range("A21") = "○"
'        Range("B21") = Empty
'        Application.OnKey "%{F3}", "選択部分再計算"
'
'    End Sub
'
'    Function 選択部分再計算()
'
'        On Error Resume Next
'        Selection.Calculate
'        On Error GoTo 0
'
'    End Function

■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆
◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■◆■

'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ ファイル作成
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●マイドキュにテキスト作成
    Dim intFileNum         As Integer
    Dim strFileName        As String

    intFileNum = FreeFile
    strFileName = "●Sample.txt"
    Open strFileName For Output As intFileNum
    Close #intFileNum

    '●マイドキュにテキスト作成(名前任意)
    strFileName = InputBox("ファイル名を指定してください")
    If strFileName <> "" Then
        strFileName = strFileName & ".txt"
        Open strFileName For Output As intFileNum
        Close #intFileNum
    End If

'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■[名前の管理]の一覧を作成する
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●名前を更新
    '①
    ActiveWorkbook.Names("test2").RefersTo = _
        "='\\fileserver\CoffeeCrazy2\シエンプレ\数値管理チーム(重要)\ファイル受け渡し用\村田\test\[テストデータ.xlsx]Sheet1'!C1:D113"

    '②アクティブセルに対する相対位置でRC指定
    ActiveWorkbook.Names("test2").RefersToR1C1 = _
        "='\\fileserver\CoffeeCrazy3\シエンプレ\数値管理チーム(重要)\ファイル受け渡し用\村田\test\[テストデータ.xlsx]Sheet1'!RC[2]:R[112]C[5]"

    ActiveWorkbook.Names("test2").RefersToR1C1 = _
        "='\\fileserver\CoffeeCrazy2\シエンプレ\数値管理チーム(重要)\ファイル受け渡し用\村田\test\[テストデータ.xlsx]Sheet1'!R[-7]C[-13]:R[-3]C[-11]"



    '●[名前の管理]の一覧を作成する

    Dim nm As Name
    Dim i As Long

    Worksheets.Add Before:=Sheets(1)
    Worksheets.Add After:=Sheets(Sheets.Count)
    Range("A1") = "名前"
    Range("B1") = "範囲(修正前)"
    Range("C1") = "[!]の位置"
    Range("D1") = "シート名"
    Range("E1") = "'$1"
    Range("F1") = "'$2"
    Range("G1") = "'$3"
    Range("H1") = "'$4"
    Range("I1") = "末尾行"
    Range("J1") = "範囲(編集後)"
    Range("K1") = "範囲(編集後) - マクロ用コード"

    i = 2
    For Each nm In Names
        Cells(i, 1).Value = nm.Name
        Cells(i, 2).Value = "'" & nm.RefersTo
        i = i + 1
    Next nm
    Columns("A:B").AutoFit

    '●数式の設定(作業用)

    vR_end = Range("A1048576").End(xlUp).Row
    Range("C2") = "=IF(ISERROR(FIND(""!"",A2)),IF(ISERROR(FIND(""!"",B2)),"""",FIND(""!"",B2)),"""")"
    Range("D2") = "=IF(ISERROR(MID(B2,2,C2-2)),"""",MID(B2,2,C2-2))"
    Range("C2:D2").AutoFill Destination:=Range("C2:D" & vR_end)



    '●名前の更新

    For i1 = 2 To vR_end

        vFlag = 0

        If Cells(i1, 4) = Empty Then
            Rows(i1).EntireRow.Hidden = True
        Else

            'シートの存在判断
            For Each vSheet In Worksheets
                If vSheet.Name = Cells(i1, 4) Then
                    vFlag = 1
                    Exit For
                End If
                If vSheet.Name = Cells(i1, 4) Then vFlag = vFlag + 1
            Next vSheet

            '末尾行の設定
            If vFlag = 1 Then
                vSheet = Cells(i1, 4).Value
                With Sheets(vSheet)
                    vC_end0 = .Range("A1").SpecialCells(xlLastCell).Column
                    For i2 = 1 To vC_end0
                        vR_end1 = .Cells(1048576, i2).End(xlUp).Row
                        If i = 1 Then
                            vR_end = vRow_end1
                        Else
                            vR_end = Application.WorksheetFunction.Max(vR_end1, vR_end2)
                        End If
                        vR_end2 = vR_end
                    Next i2

                End With
            End If

            '式を入力
            vName = Cells(i1, 1)
            vSheet_name = Cells(i1, 4)
            Cells(i1, 5) = "=FIND(""$"",B" & i1 & ",C" & i1 & ")"
            Cells(i1, 6) = "=FIND(""$"",B" & i1 & ",E" & i1 & "+1)"
            Cells(i1, 7) = "=FIND(""$"",B" & i1 & ",F" & i1 & "+1)"
            Cells(i1, 8) = "=FIND(""$"",B" & i1 & ",G" & i1 & "+1)"
            Cells(i1, 9) = vR_end
            Cells(i1, 10) = "=LEFT(B" & i1 & ",H" & i1 & ")&I" & i1

            'マクロ更新用コード
            vC1 = Mid(Cells(i1, 2), Cells(i1, 5) + 1, Cells(i1, 6) - Cells(i1, 5) - 1)
            vC1 = Range(vC1 & i1).Column
            vR1 = Mid(Cells(i1, 2), Cells(i1, 6) + 1, Cells(i1, 7) - Cells(i1, 6) - 2)
            vC2 = Mid(Cells(i1, 2), Cells(i1, 7) + 1, Cells(i1, 8) - Cells(i1, 7) - 1)
            vC2 = Range(vC2 & i1).Column
            vR2 = Cells(i1, 9)
            Cells(i1, 11) = "'=" & vSheet_name & "!R" & vR1 & "C" & vC1 & ":R" & vR2 & "C" & vC2

            '名前の更新
            ActiveWorkbook.Names(vName).RefersToR1C1 = "=" & vSheet_name & "!R" & vR1 & "C" & vC1 & ":R" & vR2 & "C" & vC2

        End If

    Next i1

'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ 他のマクロを実行
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    Application.Run "置換ファイル.xlsm!文字_置換"


'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ アプリケーション操作
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '起動
    Shell ("notepad")                'ノートパッド
    Shell ("calc")                   '電卓
    Shell ("explorer")               'エクスプローラ
    Shell ("freecell")               'フリーセル
    Shell ("cmd")                    'コマンドプロンプト
    'パスを指定して起動する方法
    Shell ("c:\program Files\Windows Media Player\wmplayer.exe")

    Set xlAPP = Application
    Selection = xlAPP.Name      '⇒Microsoft Excel


'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ Shell
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    'http://www.max.hi-ho.ne.jp/happy/YNxv251_12tbl.html

    'http://officetanaka.net/excel/vba/statement/AppActivate.htm
    'http://officetanaka.net/excel/vba/function/Shell.htm

    '●アプリを開く
    Application.ActivateMicrosoftApp xlMicrosoftWord
        ret = Shell("●アプリパス")
    ret = Shell("●アプリパス ●ファイルパス")

    '●Shellで起動させたアプリを終了させる
    vアプリ = FindWindow(vbNullString, "●アプリ名")
    If vアプリ <> 0& Then
        SendMessage vアプリ, WM_SYSCOMMAND, SC_CLOSE, 0
        Hwnd = 0&
    End If

    '●アプリをアクティブにする
    vアプリ = Shell("●アプリパス", 1)
    AppActivate vアプリ

    AppActivate "Sample.txt - メモ帳", True
    AppActivate "Microsoft Excel", True


    Application.Wait Now + TimeSerial(0, 0, 2)

    '●IE操作
    Dim URL As String, IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    URL = "http://www.moug.net/"
    With IE
        .Visible = True
        .Navigate URL
    End With
    Set IE = Nothing

    '●ファイルを起動
    CreateObject("Wscript.Shell").Run vFolder & "\" & vFile, 5

    '●処理をストップ
    Application.Wait Now + TimeValue("0:00:" & vTime2)



'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ 開かないでデータを読み込む
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━


    For i = 1 To 20
        Cells(i, 1) = ExecuteExcel4Macro("'C:\[Book1.xls]Sheet1'!R" & i & "C1")
    Next i



'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ マウスポイント
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    Application.Cursor = xlDefault          ' デフォルト「+」
    Application.Cursor = xlWait             ' 「砂時計」
    Application.Cursor = xlNorthwestArrow   ' 「矢印」
    Application.Cursor = xlIBeam            ' 「I 字型」

    Application.Cursor = -4143              'デフォルト +
    Application.Cursor = 1                  '矢印
    Application.Cursor = 2                  '砂時計
    Application.Cursor = 3                  'I



'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' ■ 他
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●デスクトップを表示
    CreateObject("Shell.Application").ToggleDesktop

    '●更新日時
    更新日時 = ActiveWorkbook.BuiltinDocumentProperties("LAST SAVE TIME")
    最終アクセス日時 = CreateObject("scripting.FileSystemObject").GetFile(フルパス).DateLastAccessed


    '●Excelのバージョン
    AppVersion = Application.Version
    Select Case AppVersion
    Case Is = 5
        MsgBox "Excel 5.0です"
    Case Is = 7
        MsgBox "Excel 95です"
    Case Is = 8
        MsgBox "Excel 97です"
    Case Is = 9
        MsgBox "Excel 2000です"
    Case Is = 10
        MsgBox "Excel 2002です"
    Case Is = 11
        MsgBox "Excel 2003です"
    Case Is = 12
        MsgBox "Excel 2007です"
    Case Is = 14
        MsgBox "Excel 2010です"
    Case Else
        MsgBox "不明です"
    End Select


    '●クリップボードに格納
    vText = "test"
    With New MSForms.DataObject
        .SetText vText      '変数の値をDataObjectに格納する
        .PutInClipboard   'DataObjectのデータをクリップボードに格納する
    End With


End Function
 

フォルダ名

 投稿者:(^・(O_O)・^)  投稿日:2016年 2月12日(金)01時26分36秒
  サブフォルダパス サブフォルダ名 ファイル


Sub フォルダ情報()

    Application.ScreenUpdating = False

    MaxRow = Rows.Count
    vFolder = Sheets("マスタ").Range("フォルダ1")

    '●シートのクリア
    Rows("2:" & MaxRow).ClearContents


    '●フォルダの存在確認
    On Error Resume Next
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFS.GetFolder(vFolder & "\")
    If objFolder = Empty Then
        Sheets("マスタ").Select
        Application.ScreenUpdating = True
        Range("フォルダ1").Select
        MsgBox "指定のフォルダに、ファイルは存在しません。", vbExclamation
        End
    End If


    '●フォルダパス一覧
    i = 2
    For Each objSubFolder In objFolder.subFolders
        Cells(i, 1) = objSubFolder
        i = i + 1
    Next


    '●フォルダ名一覧
    i = 2
    Do While (Cells(i, 1) <> "")
        vFolder = Cells(i, 1)
        vFolder = Dir(vFolder, vbDirectory)
        Cells(i, 2) = vFolder
        i = i + 1
    Loop


    '●ファイル一覧
    i = 2
    Do While (Cells(i, 1) <> "")

        vFolder = Cells(i, 1)
        vFile = Dir(vFolder & "\" & "*", vbNormal)
        flag = False
        Do While vFile <> ""
            If flag = False Then
                Cells(i, 3) = vFile
                flag = True
            Else
                i = i + 1
                Rows(i).Insert
                Cells(i, 1) = Cells(i - 1, 1)
                Cells(i, 2) = Cells(i - 1, 2)
                Cells(i, 3) = vFile
            End If
            vFile = Dir()
        Loop

        i = i + 1
    Loop


    Application.ScreenUpdating = True

End Sub
 

ファイル名変更システム

 投稿者:(^・(O_O)・^)  投稿日:2016年 2月12日(金)01時20分6秒
  Sub ファイル名変更_置換_先頭()

    '●ファイル名:先頭文字の置換

    '○変数
    vPass = Sheets("ファイル").Range("パス1").Value & "\"
    vName1 = Sheets("ファイル").Range("ネーム_before").Value        '置換前
    vName2 = Sheets("ファイル").Range("ネーム_after").Value         '置換後
    v拡張子 = Sheets("ファイル").Range("拡張子").Value              '拡張子
    If v拡張子 = Empty Then
        vFile = Dir(vPass & "\*")                            'ファイル名
    Else
        vFile = Dir(vPass & "\*." & v拡張子)                            'ファイル名
    End If
    vLen1 = Len(vName1)                                             'Len(置換前)
    vLen2 = Len(v拡張子)                                            'Len(拡張子)

    On Error Resume Next

    Do While vFile <> ""
        vFile1a = Left(vFile, Len(vFile) - (vLen2 + 1))             'ファイル名
        vFile1b = Right(vFile1a, Len(vFile) - (vLen2 + 1 + vLen1))  'ファイル名(置換前の文字抜き)
        aa = Left(vFile1a, vLen1)

        '●置換
        If v拡張子 <> Empty Then
            If Left(vFile1a, vLen1) = "" & vName1 & "" Then             'ファイル名の先頭が『置換前』の時
                If vName2 = Empty Then
                    Name vPass & vFile1a & "." & v拡張子 As vPass & vName2 & vFile1b & "." & v拡張子
                Else
                    Name vPass & vFile1a & "." & v拡張子 As vPass & vName2 & vFile1b & "." & v拡張子
                End If
            Else
                If vName1 = Empty Then
                    Name vPass & vFile1a & "." & v拡張子 As vPass & vName2 & vFile1b & "." & v拡張子
                Else
                End If
            End If
        ElseIf v拡張子 = Empty Then
            n拡張子 = InStrRev(vFile, ".")
            If Left(vFile1a, vLen1) = "" & vName1 & "" Then             'ファイル名の先頭が『置換前』の時
                If vName2 = Empty Then
                    Name vPass & vFile1a As vPass & vName2 & vFile1b
                Else
                    Name vPass & vFile1a As vPass & vName2 & vFile1b
                End If
            Else
                If vName1 = Empty Then
                    Name vPass & vFile1a & "." & v拡張子 As vPass & vName2 & vFile1b
                Else
                End If
            End If
        End If


        vFile = Dir()
    Loop

    On Error GoTo 0

End Sub


Sub ファイル名変更_置換_末尾()

    '●ファイル名:末尾文字の置換

    '○変数
    vPass = Sheets("ファイル").Range("パス1").Value & "\"
    vName1 = Sheets("ファイル").Range("ネーム_before").Value        '置換前
    vName2 = Sheets("ファイル").Range("ネーム_after").Value         '置換後
    v拡張子 = Sheets("ファイル").Range("拡張子").Value              '拡張子
    vFile = Dir(vPass & "\*." & v拡張子)                            'ファイル名
    vLen1 = Len(vName1)                                             'Len(置換前)
    vLen2 = Len(v拡張子)                                            'Len(拡張子)

    On Error Resume Next

    Do While vFile <> ""
        vFile1a = Left(vFile, Len(vFile) - (vLen2 + 1))             'ファイル名
        vFile1b = Left(vFile, Len(vFile) - (vLen2 + 1 + vLen1))     'ファイル名(置換前の文字抜き)
        aa = Right(vFile1a, vLen1)

        If Right(vFile1a, vLen1) = "" & vName1 & "" Then            'ファイル名に(文字)置換前が含まれていたら置換
            If vName2 = Empty Then
                Name vPass & vFile1a & "." & v拡張子 As vPass & vFile1b & "." & v拡張子
            Else
                Name vPass & vFile1a & "." & v拡張子 As vPass & vFile1b & vName2 & "." & v拡張子
            End If
        Else
        End If

        vFile = Dir()
    Loop

    On Error GoTo 0

End Sub

Sub clear_ファイル_フォルダ名()
    '●ファイル名のリセット
    Range("B1").Value = Empty
End Sub

Sub ファイル_フォルダ名_三浦()
    '●ファイル名:③三浦作業用
    Range("B1").Value = "M:\00ダメージ\ダメージ報告書ボックス(DC)\00処理フォルダ\③三浦作業用"
End Sub

Sub clear_ファイル_置換名()
    '●置換前・置換後のリセット
    Range(Cells(5, 2), Cells(6, 2)).Value = Empty
End Sub

Sub Before_0()
    Range("ネーム_before").Value = ""
End Sub

Sub Before_①()
    Range("ネーム_before").Value = "①"
End Sub

Sub after_0()
    Range("ネーム_after").Value = ""
End Sub

Sub after_①()
    Range("ネーム_after").Value = "①"
End Sub
 

ファイル

 投稿者:(^・(O_O)・^)  投稿日:2015年12月12日(土)23時27分21秒
編集済
  http://geocities.yahoo.co.jp/admin/
http://www.geocities.jp/mu_tyo/data/date_15-1212



Sub b1()
    Application.OnKey "^q", "b2"
End Sub

Sub b2()
    MsgBox "test"
End Sub
 

レンタル掲示板
/5