[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数エクセルファイルの自動置換マクロ』（まこ）
ヘッダにある 、 だけを取り除きたいです。
ひとつのエクセルファイルごとに行選択して置換でできますが、無数のファイルがあるとき困ってしまいます。
例えばエクセルファイルをドラッグしてあるソフトに入れれば、自動で上記のことができて吐きだされるというものはマクロでできるのでしょうか。
もしくはエクセルファイルを複数選択してあるソフトへドラッグしたら自動置換されてはきだれるというようなものです。よろしくお願いいたします。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
エクセルファイルにあるヘッダーとは、そのブックのどのシートのどこにあるのでしょうか？
ドラッグして、ほうり込むというイメージは、たとえばエクスプローラ上で複数のブックを選択してＯＫボタンを押すといったことでもよろしいですか？
吐き出されるというのは、自動置き換え後、保存されるということでいいですか？
（β） 2015/04/04(土) 08:27
Sub aaa()
Dim a As Long
Dim Path As String
Dim u As String
Dim b As Long
a = 1
Path = "エクセルファイルが入っているフォルダのパス名+\"
'記入例 C:\Users\ユーザー名\Documents\aba\
u = Dir(Path & "*.xlsx")
Do Until u = ""
Cells(a, 1).Value = u
u = Dir()
a = a + 1
Loop
b = a
a = 1
Do Until a = b
Workbooks.Open Path & Cells(a, 1).Value
Workbooks(Cells(a, 1).Value).Sheets(1).Rows("1:1").Delete Shift:=xlUp
Workbooks(Cells(a, 1).Value).Save
Workbooks(Cells(a, 1).Value).Close
a = a + 1
Loop
End Sub
（スズメ） 2015/04/04(土) 10:21
To スズメさん
おそらく、どこかのセルにある先頭の 、 だけを消去したいんだと思います。 現在手作業で【置換】で処理しておられるのですから。 それはともあれ。
'記入例 C:\Users\ユーザー名\Documents\aba\
ユーザー名をハードコーディングすると、他のＰＣで実行した時に動かなくなります。 これらパスは、動的に取得することが必要です。以下、参考コードです。
Sub Sample1()
Dim path As String
path = CreateObject("WScript.Shell").Specialfolders("DeskTop")
MsgBox path
path = CreateObject("WScript.Shell").Specialfolders("myDocuments")
MsgBox path
path = Environ("USERPROFILE")
MsgBox path
End Sub
また、後半のループ、これは For/Next で書くべきところですね。 というか、前半で処理してしまえば、後半は不要ですけどね。
（β） 2015/04/04(土) 10:36
マクロ内で表示されるファイル選択ダイアログ上で、処理したいブックを複数選択し、ＯＫを押せば実行します。 とりあえず、選択されたブックの最初のシートの１行目にある "、" を消去しています。 場所は、そこではなく、ここ とか、たとえば、各セルの先頭にあるものだけ 等々 要件については 言ってもらえれば対応します。
Sub Test()
Dim fList As Variant
Dim fName As Variant
Dim bk As Workbook
'処理したいブックの選択。複数選択可能。
fList = Application.GetOpenFilename(FileFilter:="対象ブック,*.xls*", MultiSelect:=True)
If Not IsArray(fList) Then Exit Sub 'キャンセルボタン
Application.ScreenUpdating = False
For Each fName In fList
Set bk = Workbooks.Open(fName)
bk.Sheets(1).UsedRange.Rows(1).Replace What:="、", Replacement:="", LookAt:=xlPart
bk.Close True
Next
MsgBox "クリーニング、完了です"
End Sub
（β） 2015/04/04(土) 11:13
ドロップしたいというところに反応して、お遊びのコードです。
新規ファイルに下記のマクロを置き、適当な名前を付けてマクロブックとして保存して 閉じます。
もう一度このファイルを開くと、ファイルと同じフォルダに、 「ここにファイルをドロップしてください.vbs」 というファイルができるので、ここに処理をしたい EXCEL ファイルをドロップします。
ヘッダ内（各シートの1行目）の「、」が削除されます。 このマクロファイルを閉じると「ここにファイルをドロップしてください.vbs」も消えます。
マクロの設定
EXCEL から Alt+F11 で開いたウィンドウで、
ツール ⇒ 参照設定 Microsoft Scripting Runtime にチェックします。
ThisWorkbook の下に 「（１）ThisWorkbook モジュール」のコードを
挿入⇒標準モジュール で開いたウィンドウに 「（２）標準モジュール」のコードを置きます。
（１）ThisWorkbook モジュール
−−−−−−−−−−−−−−−−−−−−−−
Private Sub Workbook_Open()
CleanupHeaderConstructor
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
CleanupHeaderDestructor
End Sub
−−−−−−−−−−−−−−−−−−−−−−
（２）標準モジュール −−−−−−−−−−−−−−−−−−−−−− Option Explicit
Const ScriptName = "ここにファイルをドロップしてください.vbs" Const ListName = "CleanupHeaderList.txt"
Public NextScheduleTime
'//-----------------------------
Sub CleanupHeaderConstructor()
'//-----------------------------
Dim fso As New Scripting.FileSystemObject
Dim dropScriptPath
dropScriptPath = ThisWorkbook.Path & "\" & ScriptName
'// スクリプトの作成
Dim ListFilePath
ListFilePath = ThisWorkbook.Path & "\" & ListName
With fso.CreateTextFile(dropScriptPath, True)
.WriteLine "Dim fso"
.WriteLine "Set fso = CreateObject(""Scripting.FileSystemObject"")"
.WriteLine "If WScript.Arguments.Count = 0 Then WScript.Quit"
.WriteLine "With fso.OpenTextFile(""" & ListFilePath & """, 8, True )"
.WriteLine " For i=0 To WScript.Arguments.Count - 1"
.WriteLine " .WriteLine WScript.Arguments(i)"
.WriteLine " Next"
.WriteLine " .Close"
.WriteLine "End With"
.Close
End With
Dim wsh
Set wsh = CreateObject("WScript.Shell")
'// デスクトップショートカットの作成
Dim ShortCutPath
ShortCutPath = wsh.SpecialFolders("Desktop") & "\" & Replace(ScriptName, ".vbs", ".lnk")
With wsh.CreateShortcut(ShortCutPath)
.TargetPath = dropScriptPath
.IconLocation = "shell32.dll,43"
.Save
End With
'// スケジュールの設定
With ThisWorkbook.Worksheets(1)
.Range("A1:B1") = Array("実行時間", "処理ファイル")
.Columns("A").NumberFormatLocal = "YYYY/MM/DD hh:mm:ss"
.Columns("A").ColumnWidth = 20
End With
CleanupHeader
End Sub
'//-----------------------------
Sub CleanupHeaderDestructor()
'//-----------------------------
Dim fso As New Scripting.FileSystemObject
'// スクリプトの削除
Dim dropScriptPath
dropScriptPath = ThisWorkbook.Path & "\" & ScriptName
If fso.FileExists(dropScriptPath) Then fso.DeleteFile dropScriptPath
Dim wsh
Set wsh = CreateObject("WScript.Shell")
'// デスクトップショートカットの削除
Dim ShortCutPath
ShortCutPath = wsh.SpecialFolders("Desktop") & "\" & Replace(ScriptName, ".vbs", ".lnk")
If fso.FileExists(ShortCutPath) Then fso.DeleteFile ShortCutPath
'// スケジュールの解除
On Error Resume Next
Application.OnTime NextScheduleTime, "CleanupHeader", , False
End Sub
'//-----------------------------
Sub CleanupHeader()
'//-----------------------------
Dim fso As New Scripting.FileSystemObject
Dim ListFilePath
ListFilePath = ThisWorkbook.Path & "\" & ListName
Dim fl
Dim f
Dim ff
Dim ws As Worksheet
If fso.FileExists(ListFilePath) = True Then
fl = Split(fso.OpenTextFile(ListFilePath).ReadAll(), vbNewLine)
fso.DeleteFile ListFilePath
For Each f In fl
'// ドロップされたのがフォルダだったら、中のフォルダとファイルをリストに追記
If fso.FolderExists(f) Then
With fso.OpenTextFile(ListFilePath, 8, True)
For Each ff In fso.GetFolder(f).SubFolders
.WriteLine ff.Path
Next
For Each ff In fso.GetFolder(f).Files
.WriteLine ff.Path
Next
.Close
End With
End If
'// ドロップされたのが EXCEL ファイルだったら全シートを処理
If InStr(LCase(fso.GetExtensionName(f)), "xls") > 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
With Workbooks.Open(f)
For Each ws In .Worksheets
ws.Rows(1).Replace What:="、", Replacement:="", LookAt:=xlPart '// 置換処理
Next
.Save
.Close
End With
'// 先頭シートに実行履歴を記録
With ThisWorkbook.Worksheets(1)
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 2) = Array(Now(), f)
End With
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
Next
End If
NextScheduleTime = Now + TimeValue("00:00:05")
Application.OnTime NextScheduleTime, "CleanupHeader"
End Sub
−−−−−−−−−−−−−−−−−−−−−−
（Mook） 2015/04/04(土) 11:30
To Mookさん
わぁ、おもしろいですね！ 勉強になりますし、今後、この手法、パクらせてもらうかもです。
同時にデスクトップにショートカットを作り出して、そこにドロップしてもらうのもいいかもしれませんね。
ところで、Sub CleanupHeaderConstructor() の With fso.CreateTextFile(dropScriptPath) この End With の前に .Close が抜けてませんか？
（β） 2015/04/05(日) 07:05
確かにお行儀悪いかもしれませんが、プロシージャやスクリプト終了時にフラッシュ されると（勝手に）信じているので、単一ファイルの処理では省略して使ってますが、 ここはお行儀よく .Close しておいた方が良いですね。
修正しました。 （ダブルで抜けていました。）
ファイルはデスクトップに出す方がアイデアとしては面白いですね。 アイコンを変えたり、フォルダをドロップしたら下を検索したりと、 改善の余地は多々あると思います。
（Mook） 2015/04/05(日) 10:10
自分のコメントに、自分で対応ｗ。
以下、変更点です。 ・デスクトップにアイコンを表示（★アイコン） ・フォルダをドロップすると、フォルダ以下のファイルを処理 ・処理した時間とファイルの履歴を先頭シートに表示
に対応したコードに差し替えました。
（Mook） 2015/04/05(日) 20:58
（Mook） 2015/04/05(日) 21:38 追加修正
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.