A1は空白
A2はタイトル（仮に：ファイル）
A3以下ファイルパス+ファイル名まで
===================================
Option Explicit
Sub FileKiller()
Dim i As Variant
On Error Resume Next
i = 3
Do Until Cells(i, 1) = ""
Range("A" & i).Select
Kill ActiveCell
i = i + 1
Loop
MsgBox "終了"
End Sub
===================================
===================================
Option Explicit
Sub test() ' テストプログラム
DeleteFolders "C:\Users\琳子_naomi\Desktop\aaa"
End Sub
' ﾌｫﾙﾀﾞｰ削除関数
' 指定ﾌｫﾙﾀﾞｰ内の空ﾌｫﾙﾀﾞｰを削除する
' 指定ﾌｫﾙﾀﾞｰ内にﾌｧｲﾙﾌｫﾙﾀﾞｰが一個も無くなったら True を返す
Private Function DeleteFolders(Path As String) As Boolean
Dim FilesCnt As Long ' このﾌｫﾙﾀﾞｰ内のﾌｧｲﾙの数
Dim Folders() As String ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰ一覧
Dim FoldersCnt As Long ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰの数
Dim FileName As String
Dim NewPath As String
Dim i As Long
FilesCnt = 0 ' このﾌｫﾙﾀﾞｰ内のﾌｧｲﾙの数を0に
FoldersCnt = 0 ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰの数を0に
ReDim Folders(0 To 0) ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰ一覧をｸﾘｱ
FileName = Dir(Path & "\*.*", vbDirectory) ' ﾌｧｲﾙ/ﾌｫﾙﾀﾞｰの初期検索
While FileName <> "" ' ﾌｧｲﾙ/ﾌｫﾙﾀﾞｰが無くなるまで繰り返す
If FileName <> "." And FileName <> ".." Then
NewPath = Path & "\" & FileName
If (GetAttr(NewPath) And vbDirectory) = vbDirectory Then
' 検索したのがﾌｫﾙﾀﾞｰならﾌｫﾙﾀﾞｰ一覧の登録とﾌｫﾙﾀﾞｰ数のｶｳﾝﾄｱｯﾌﾟ
FoldersCnt = FoldersCnt + 1
ReDim Preserve Folders(0 To FoldersCnt)
Folders(FoldersCnt) = NewPath
Else
' 検索したのがﾌｧｲﾙならﾌｧｲﾙ数のｶｳﾝﾄｱｯﾌﾟ
FilesCnt = FilesCnt + 1
End If
End If
FileName = Dir ' 次のﾌｧｲﾙ/ﾌｫﾙﾀﾞｰの検索
Wend
' 下位の各ﾌｫﾙﾀﾞｰでの削除処理を行う
For i = 1 To UBound(Folders)
' 自身を呼び出して下位ﾌｫﾙﾀﾞｰの削除を行う
If DeleteFolders(Folders(i)) = True Then
' Trueでﾘﾀｰﾝしたらﾌｫﾙﾀﾞｰの削除とﾌｫﾙﾀﾞｰ個数 -1 する
RmDir Folders(i)
FoldersCnt = FoldersCnt - 1
End If
Next i
' ﾌｫﾙﾀﾞｰもﾌｧｲﾙも無くなったら True
' 一方でも残っていたら False を返す
If FoldersCnt <= 0 And FilesCnt <= 0 Then
DeleteFolders = True
Else
DeleteFolders = False
End If
End Function
===================================
Option Explicit
Sub filehenkan()
Dim i As Variant
On Error Resume Next
i = 3
Do Until Cells(i, 1) = ""
Range("A" & i).Select
Workbooks.Open ActiveCell
If Right(ActiveWorkbook.Name, 4) = ".xls" Then
Dim book1 As Workbook
ActiveWorkbook.SaveAs FileName:=ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ".xlsx", _
FileFormat:=xlWorkbookDefault
Workbooks(ActiveWorkbook.Name).Close
' ElseIf Right(ActiveWorkbook.Name, 4) = ".doc" Then
' Dim book2 As Workbook
'
' Set book2 = Workbooks(ActiveWorkbook.Name & ".docx")
' book1.SaveAs FileName:=ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ".docx", _
' FileFormat:=wdFormatDocument
'
'
'
' ElseIf Right(ActiveWorkbook.Name, 4) = ".ppt" Then
' Dim book3 As Workbook
'
' Set book3 = Workbooks(ActiveWorkbook.Name & ".pptx")
' book1.SaveAs FileName:=ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ".pptx", _
' FileFormat:=ppSaveAsDefault
End If
i = i + 1
Loop
MsgBox "変換終了"
End Sub
A2はタイトル（仮に：ファイル）
A3以下ファイルパス+ファイル名まで
===================================
Option Explicit
Sub FileKiller()
Dim i As Variant
On Error Resume Next
i = 3
Do Until Cells(i, 1) = ""
Range("A" & i).Select
Kill ActiveCell
i = i + 1
Loop
MsgBox "終了"
End Sub
===================================
===================================
Option Explicit
Sub test() ' テストプログラム
DeleteFolders "C:\Users\琳子_naomi\Desktop\aaa"
End Sub
' ﾌｫﾙﾀﾞｰ削除関数
' 指定ﾌｫﾙﾀﾞｰ内の空ﾌｫﾙﾀﾞｰを削除する
' 指定ﾌｫﾙﾀﾞｰ内にﾌｧｲﾙﾌｫﾙﾀﾞｰが一個も無くなったら True を返す
Private Function DeleteFolders(Path As String) As Boolean
Dim FilesCnt As Long ' このﾌｫﾙﾀﾞｰ内のﾌｧｲﾙの数
Dim Folders() As String ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰ一覧
Dim FoldersCnt As Long ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰの数
Dim FileName As String
Dim NewPath As String
Dim i As Long
FilesCnt = 0 ' このﾌｫﾙﾀﾞｰ内のﾌｧｲﾙの数を0に
FoldersCnt = 0 ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰの数を0に
ReDim Folders(0 To 0) ' このﾌｫﾙﾀﾞｰ内のﾌｫﾙﾀﾞｰ一覧をｸﾘｱ
FileName = Dir(Path & "\*.*", vbDirectory) ' ﾌｧｲﾙ/ﾌｫﾙﾀﾞｰの初期検索
While FileName <> "" ' ﾌｧｲﾙ/ﾌｫﾙﾀﾞｰが無くなるまで繰り返す
If FileName <> "." And FileName <> ".." Then
NewPath = Path & "\" & FileName
If (GetAttr(NewPath) And vbDirectory) = vbDirectory Then
' 検索したのがﾌｫﾙﾀﾞｰならﾌｫﾙﾀﾞｰ一覧の登録とﾌｫﾙﾀﾞｰ数のｶｳﾝﾄｱｯﾌﾟ
FoldersCnt = FoldersCnt + 1
ReDim Preserve Folders(0 To FoldersCnt)
Folders(FoldersCnt) = NewPath
Else
' 検索したのがﾌｧｲﾙならﾌｧｲﾙ数のｶｳﾝﾄｱｯﾌﾟ
FilesCnt = FilesCnt + 1
End If
End If
FileName = Dir ' 次のﾌｧｲﾙ/ﾌｫﾙﾀﾞｰの検索
Wend
' 下位の各ﾌｫﾙﾀﾞｰでの削除処理を行う
For i = 1 To UBound(Folders)
' 自身を呼び出して下位ﾌｫﾙﾀﾞｰの削除を行う
If DeleteFolders(Folders(i)) = True Then
' Trueでﾘﾀｰﾝしたらﾌｫﾙﾀﾞｰの削除とﾌｫﾙﾀﾞｰ個数 -1 する
RmDir Folders(i)
FoldersCnt = FoldersCnt - 1
End If
Next i
' ﾌｫﾙﾀﾞｰもﾌｧｲﾙも無くなったら True
' 一方でも残っていたら False を返す
If FoldersCnt <= 0 And FilesCnt <= 0 Then
DeleteFolders = True
Else
DeleteFolders = False
End If
End Function
===================================
Option Explicit
Sub filehenkan()
Dim i As Variant
On Error Resume Next
i = 3
Do Until Cells(i, 1) = ""
Range("A" & i).Select
Workbooks.Open ActiveCell
If Right(ActiveWorkbook.Name, 4) = ".xls" Then
Dim book1 As Workbook
ActiveWorkbook.SaveAs FileName:=ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ".xlsx", _
FileFormat:=xlWorkbookDefault
Workbooks(ActiveWorkbook.Name).Close
' ElseIf Right(ActiveWorkbook.Name, 4) = ".doc" Then
' Dim book2 As Workbook
'
' Set book2 = Workbooks(ActiveWorkbook.Name & ".docx")
' book1.SaveAs FileName:=ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ".docx", _
' FileFormat:=wdFormatDocument
'
'
'
' ElseIf Right(ActiveWorkbook.Name, 4) = ".ppt" Then
' Dim book3 As Workbook
'
' Set book3 = Workbooks(ActiveWorkbook.Name & ".pptx")
' book1.SaveAs FileName:=ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ".pptx", _
' FileFormat:=ppSaveAsDefault
End If
i = i + 1
Loop
MsgBox "変換終了"
End Sub
