Sub DELETESHAPE()


    Dim RowN As Integer
    

    ''エクセルシート上で選択した範囲内の全ての図形を削除する

    Set select_range = Range(Cells(6, 1), Cells(10000, 4))
    select_range.ClearContents
    If ActiveSheet.Shapes.Count > 2 Then
        For i = ActiveSheet.Shapes.Count To 1 Step -1
            With ActiveSheet.Shapes(i)
                Set shp_rng = Range(.TopLeftCell, .BottomRightCell)
                If Not Intersect(shp_rng, select_range) Is Nothing Then
                    ActiveSheet.Shapes(i).Delete
                End If
            End With
        Next i
    End If
    
End Sub

Sub JIKKOU2()

    Dim RowN As Integer
    
    ''エクセルシート上で選択した範囲内の全ての図形を削除する

    Set select_range = Range(Cells(6, 1), Cells(10000, 4))
    select_range.ClearContents
    If ActiveSheet.Shapes.Count > 2 Then
        For i = ActiveSheet.Shapes.Count To 1 Step -1
            With ActiveSheet.Shapes(i)
                Set shp_rng = Range(.TopLeftCell, .BottomRightCell)
                If Not Intersect(shp_rng, select_range) Is Nothing Then
                    ActiveSheet.Shapes(i).Delete
                End If
            End With
        Next i
    End If
        
    Application.ScreenUpdating = False '画面更新をOFF
    Application.Calculation = xlManual '自動計算をOFF
    Application.EnableEvents = False 'イベントをOFF
    
    LASTY = Cells(Rows.Count, 2).End(xlUp).Row '1を任意に替える
        
    Call searchPic(Cells(3, 4), 6) '←検索したいフォルダを指定する。ColNは張り付け始める位置。
         
    Application.ScreenUpdating = True '画面更新をON
    Application.Calculation = xlAutomatic '自動計算をON
    Application.EnableEvents = True 'イベントをON
     
End Sub
  
Sub searchPic(PATH As String, ColN As Integer)
    Dim buf As String, childf As Object
 
'フォルダ内全部
    buf = Dir(PATH & "\*.png")
   
    Do While buf <> ""
     
        Cells(ColN, 1).Value = ParentDirName(PATH)
        Cells(ColN, 2).Value = buf
        Cells(ColN, 3).Activate
       '名前が一致したら実行するように指示。
       
        myFileName = PATH & "\" & buf
         
        '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
        Set myShape = ActiveSheet.Shapes.AddPicture( _
              Filename:=myFileName, _
              LinkToFile:=True, _
              SaveWithDocument:=False, _
              Left:=Selection.Left + 1, _
              Top:=Selection.Top + 1, _
              Width:=0, _
              Height:=0)
              
        '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする
        With myShape
            .ScaleHeight 1.5, msoTrue
            .ScaleWidth 1.5, msoTrue
        End With
            
        ColN = ColN + 1
        
       
       '次のファイル
           buf = Dir()
    Loop
     
    '子フォルダも同様に、subFolderを実行する。
    With CreateObject("Scripting.FileSystemObject")
        For Each childf In .GetFolder(PATH).SubFolders
            Call searchKatashiki(childf.PATH, ColN)
        Next
    End With
     
End Sub


Function ParentDirName(PATH As String) As String

    ParentDirName = Left(PATH, InStrRev(PATH, "\") - 1)
    ParentDirName = Mid(ParentDirName, InStrRev(ParentDirName, "\") + 1)
    


'  With ThisWorkbook
'    ParentDirName = Left(ParentDirName, InStrRev(ParentDirName, "\") - 1)
'  End With


End Function

Sub ファイル一覧()
Dim buf As String
Dim i As Long
Dim Path As String
 
'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1)
    End With
 
'エクセルのみ抽出
    buf = Dir(Path & "\*.xlsx")
    
    Cells(2, 3).Value = "フォルダ⇒"
    Cells(2, 4).Value = "=HYPERLINK(""" & Path & """,""リンク"")"
    Cells(2, 5) = Path
     
     
'CELL B2からスタート。
     
     
   Cells(4, 2) = "No"
   Cells(4, 3) = "ファイル名"
   Cells(4, 4) = "リンク"
   Cells(4, 5) = "パス"
   Cells(4, 6) = "名前を変更したい場合↓"
      
     i = 4
     
    Do While buf <> ""
        i = i + 1
'No
        Cells(i, 2) = i - 4
'ファイル名
        Cells(i, 3) = buf
'リンクを
        LINK = Path & "\" & buf
        Cells(i, 4).Value = "=HYPERLINK(""" & LINK & """,""リンク"")"
        Cells(i, 5).Value = LINK
 
        buf = Dir()
    Loop
    
    Columns(5).ShrinkToFit = True

    
 
End Sub

Sub ファイル名前変更()
Dim buf As String
Dim i As Long
Dim Path As String
 
'フォルダの選択
    Path = Cells(2, 5)
    
    LASTY = Cells(Rows.Count, 3).End(xlUp).Row

    For i = 5 To LASTY
    
        If Cells(i, 6) <> "" Then
        
            OldName = Path & "\" & Cells(i, 3)

            '拡張子有り無しで分岐
            If InStr(1, Cells(i, 6), ".") > 0 Then
            
                NewName = Path & "\" & Cells(i, 6)
            
            Else
            
                KAKUCHOUSHI = Mid(Cells(i, 3), InStr(1, Cells(i, 3), "."))
                NewName = Path & "\" & Cells(i, 6) & KAKUCHOUSHI
            
            End If
        
            '名前の変更
            Name OldName As NewName
            Cells(i, 7) = "完了"
        
        End If
    
    Next
 
End Sub

Sub ファイル一覧()
Dim buf As String
Dim i As Long
Dim Path As String

'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1)
    End With

'エクセルのみ抽出
    buf = Dir(Path & "\*.xlsx")

'CELL B2からスタート。    
     i = 1
    Do While buf <> ""
        i = i + 1
'No
        Cells(i, 2) = i
'ファイル名
        Cells(i, 3) = buf
'リンクを
        LINK = Path & "\" & buf
        Cells(i, 4).Value = "=HYPERLINK(""" & LINK & """,""リンク"")"

        buf = Dir()
    Loop

End Sub

Dim ExcelApp
Dim ExcelBook
Dim FilePath

FilePath = "G:\共有ドライブ\TEST_FOLDER\utf-8_to_shiftjis.xlsm" '←ここを変更
VBA_P = "TEST1" '←ここを変更

Set ExcelApp=CreateObject("Excel.Application")
Set ExcelBook= ExcelApp.Workbooks.Open(FilePath)
ExcelApp.ActiveWorkbook.Worksheets(1).select

ExcelApp.visible = false

ExcelApp.Run VBA_P

ExcelBook.Close True
ExcelApp.quit

Set ExcelApp=Nothing
Set ExcelBook=Nothing

Set ExcelApp=CreateObject("Excel.Application")
Set ExcelBook= ExcelApp.Workbooks.Open(FilePath)

ExcelApp.ActiveWorkbook.Worksheets(1).select

ExcelApp.visible = false

ExcelApp.Run VBA_P

ExcelBook.Close True
ExcelApp.quit

Set ExcelApp=Nothing
Set ExcelBook=Nothing

selection.Replace 0, "", xlWhole

Sub CSV()

    MOJIRETSU = "AAAA,BBB,""1,000"",10,""15,000"""
    Debug.Print MOJIRETSU 
    
    MOJI = Split(MOJIRETSU, ",")
    
    Debug.Print 0 & "→"; MOJI(0)
    Debug.Print 1 & "→"; MOJI(1)
    Debug.Print 2 & "→"; MOJI(2)
    Debug.Print 3 & "→"; MOJI(3)
    Debug.Print 4 & "→"; MOJI(4)
    Debug.Print 5 & "→"; MOJI(5)


End Sub

AAAA,BBB,"1,000",10,"15,000"
0→AAAA
1→BBB
2→"1
3→000"
4→10
5→"15

Sub CSV2()

    MOJIRETSU = "AAAA,BBB,""1,000"",10,""15,000"""
    
    
    F = InStr(1, MOJIRETSU, """")
    If F > 0 Then
LABEL1:
        S = InStr(F + 1, MOJIRETSU, """")
        
        MOJI1 = Left(MOJIRETSU, F - 1)
        MOJI2 = Mid(Replace(MOJIRETSU, ",", "_"), F + 1, S - F - 1)
        MOJI3 = Right(MOJIRETSU, Len(MOJIRETSU) - S)
        
        MOJIRETSU = MOJI1 & MOJI2 & MOJI3
        
        F = InStr(1, MOJIRETSU, """")
        If F > 0 Then GoTo LABEL1
        
    End If
    
    
    MOJI = Split(MOJIRETSU, ",")
    
    Debug.Print MOJIRETSU 'AAAA,BBB,"1,000",10,"15,000"
    Debug.Print 0 & "→"; MOJI(0)
    Debug.Print 1 & "→"; MOJI(1)
    Debug.Print 2 & "→"; MOJI(2)
    Debug.Print 3 & "→"; MOJI(3)
    Debug.Print 4 & "→"; MOJI(4)
    

End Sub

AAAA,BBB,1_000,10,15_000
0→AAAA
1→BBB
2→1_000
3→10
4→15_000

F = InStr(1, MOJIRETSU, """")

S = InStr(F + 1, MOJIRETSU, """")

    MOJI1 = Left(MOJIRETSU, F - 1)
    MOJI2 = Mid(Replace(MOJIRETSU, ",", "_"), F + 1, S - F - 1)
    MOJI3 = Right(MOJIRETSU, Len(MOJIRETSU) - S)

    MOJIRETSU = MOJI1 & MOJI2 & MOJI3