[[20150317202709]]　『様々なフォルダ内で同じ名前のファイルを自動的に』（yuko）　ページの最後に飛ぶ

『様々なフォルダ内で同じ名前のファイルを自動的に開くようにしたい』（yuko）

教えてください。

”検索”というボタンをクリックすると、マイコンピュータの中からフォルダやファイルを選択できるようにし、
フォルダを選んでいくと、あるフォルダのなかにA、B、C、Dというフォルダがあるところまで行き着きます。
そして、この4つのフォルダの中全てにAA.txt、BB.txt、CC.txt、DD.txtという同じ名前のファイルが格納されています。
A、B、C、Dのフォルダのどれかを選ぶと、自動でBB.txtというテキストファイルを選択し、excelに転記する、ということを実行したいです。

フォルダを自分で選択でき、選択したフォルダの中に指定されたテキストファイル(上の例だとBB.txt)があれば自動でそのテキストファイルの中身を転記したいです。

どうかみなさま教えてください。。。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 選択したフォルダに BB.txtがあればマクロブックのアクティブシートに取り込みます。

 Sub Test()
    Dim fPath As String
    Dim fName As String

    fName = "BB"

    'フォルダ指定
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not .Show Then Exit Sub      'キャンセルボタン
        fPath = .SelectedItems(1) & "\" & fName & ".txt"
    End With
    'ファイルの存在確認
    If Dir(fPath) = "" Then
        MsgBox "このフォルダには指定のファイルがありません"
        Exit Sub
    End If
    '取り込み前にシートのセルをクリア
    ActiveSheet.Cells.ClearContents
    'エクセルの外部データ（テキストファイル）取り込み機能
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fPath, Destination:=Range("$A$1"))
        .Name = fName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        .Delete
    End With

 End Sub

（β） 2015/03/17(火) 21:19

返信が遅くなり申し訳ありません。

そのテキストが入っているフォルダのところで”OK”を押すと転記してくれるのですね！
有難うございます！
上手くいきました。

追加で質問ですが、テキストを貼りつける際に、スペース＊個以上、またはハイフン＊個以上あれば
そのスペースのあともしくはハイフンの後からはセルを右に一つずらして転記するのはできるのでしょうか？
選択するテキストファイルの中身を何かに置き換えればできますか？
（yuko） 2015/03/19(木) 14:27

 取り込んだ後に加工したほうがやりやすいと思います。

 確認です。データの実態が見えませんが、基本的には、取り込んだシートのA列にデータが展開されますね。

 １．なので処理は各セル毎ですね？

 ２．それと、セルのデータが

 abcd    xyz    HELLO あるいは　abcd----xyz----HELLO とあったら　３つに分けるということですね？

 ３．あたまにスペースなり ----があることはありますか？

 ４．abcd----    xyz    ----HELLO というものはありますか？

 ５．〇個　というのはどうやって指定する予定ですか？

（β） 2015/03/19(木) 15:22

そうですね。
そのまま実行させていただいたらA列に展開されていました。

1.展開されたすべての内容に対して処理を行いたいので、各セルごと行ごとで処理をしたいです

2.たとえばA1に”abcd xyz HELLO” あるいは　”abcd----xyz----HELLO” とあったら、A1=abcd、B1=xyz、C1=HELLOというように3つに分割したいです

3.頭にスペースがある可能性はあります
　また、途中途中何も書いていない行もあります

4.スペースとハイフンが混在していることはありません

5.今のところ3個以上スペースまたはハイフンが入っていると分割できれば考えています
（yuko） 2015/03/19(木) 15:55

 取り込み後のシートに対して以下のマクロを試してみてください。
 とりあえず、セル分割は１０分割までにしてあります。
 ★のところの 3 が スペースまたは - の連続文字数です。

 Sub Test2()
    Dim reg As Object
    Dim c As Range

    Application.ScreenUpdating = False

    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "(\s{3,}|-{3,})"    '★
    reg.Global = True

    With Range("A1", Range("A" & Rows.Count).End(xlUp))
        For Each c In .Cells
            c.Value = reg.Replace(c.Value, vbTab)
        Next

        .Cells.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True
    End With

 End Sub

（β） 2015/03/19(木) 16:57

できました！！！
ありがとうございます！！！
この展開をするときですが、10行目から展開したい場合は

    With Range("A10", Range("A" & Rows.Count).End(xlUp))
と
       .Cells.TextToColumns Destination:=Range("A10"), DataType:=xlDelimited, _

だけではだめなのでしょうか？
エラーが出てしまいます
（yuko） 2015/03/19(木) 18:37

追加で質問です。
セルを分割した後、余分なスペースを削除したいのですが、
reg = Replace(Replace(reg, " ", ""), "　", "")
このプログラムは間違いでしょうか
合っているとすると入れる場所がおかしいのでしょうか
自分で考えられるところに入れて試していますがエラーが出てしまいます
（yuko） 2015/03/19(木) 18:55

 >エラーが出てしまいます

 どういうエラーでしたか？こちらでは問題なく処理されますが。

 >セルを分割した後、余分なスペースを削除したいのですが

 どういったところのスペースをカットしたいのか不安ですが、コード（間違ってますけど）を見ると
 前後のみならず、文字列中のスペースもカット？
 以下は、ワークシート関数のTrimを使い、先頭、末尾に加え文字列中の連続したスペースを１つのスペースにします。

 でもTextToColumns のところは、A1->A10以外は変えてません。

 Sub Test3()
    Dim reg As Object
    Dim c As Range

    Application.ScreenUpdating = False

    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "(\s{3,}|-{3,})"    '★
    reg.Global = True

    With Range("A10", Range("A" & Rows.Count).End(xlUp))
        For Each c In .Cells
            c.Value = reg.Replace(c.Value, vbTab)
        Next

        .Cells.TextToColumns Destination:=Range("A10"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True

        .Value = Application.Trim(.Value)

    End With

 End Sub

（β） 2015/03/19(木) 19:40

作っていただいたA10に変更したものをコピペするとエラーは出ませんでした。。。
ですが、1列目から表示されてしまいます。。。
また10列目までは分割されませんでした。。。

スペースの削除対象は提示いただいたものがありがたいです。。。

Private Sub CommandButton1_Click()

    Dim fPath As String
    Dim fName As String
    Dim reg As Object
    Dim c As Range

    fName = "BB"

    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not .Show Then Exit Sub      'キャンセルボタン
        fPath = .SelectedItems(1) & "\" & fName & ".txt"
    End With

    If Dir(fPath) = "" Then
        MsgBox "このフォルダには指定のファイルがありません"
        Exit Sub
    End If
    '//取り込み前にシートのセルをクリア
    ActiveSheet.Cells.ClearContents
    '//エクセルの外部データ（テキストファイル）取り込み機能
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fPath, Destination:=Range("$A$1"))
        .Name = fName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        .Delete
    End With

    Application.ScreenUpdating = False

    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "(\s{3,}|-{3,})"    '★
    reg.Global = True

    With Range("A10", Range("A" & Rows.Count).End(xlUp))
        For Each c In .Cells
            c.Value = reg.Replace(c.Value, vbTab)
        Next

        .Cells.TextToColumns Destination:=Range("A10"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True

        .Value = Application.Trim(.Value)

    End With

End Sub
（yuko） 2015/03/19(木) 20:26

 >ですが、1列目から表示されてしまいます。。。 
 >また10列目までは分割されませんでした。。。

 ん？？？？？

 対象が1列目(A列)にありますから、それをセル分割してA,B,C,・・・・に分けたんですが？
 どのようにしたかったんですか？

 10列目までは分割されないとは、どういうことですか？意味がよくわかりません。
 もしかして 10行目？

 もともと1行目（A1)から対象にしていたのを、A10 からに変更されましたよね？
 つまり、A1～A9 は処理対象からはずすということだったんでしょ？

 一度、この機能（セル分割のみ）を操作で実感してみてください。

 セルのA1 に AAA/BBB/CCC/DDD/EEE といれ、これをA20までコピーしてください。
 で、セルのA10:A20を選択してデータタブの区切り位置->カンマやタブなどの・・・を選んで「次へ」
 でてきた画面で、その他(O)にチェックし、その横の箱に / をいれ　「完了」

 シートのセルが分割されましたね？　これがコードでやっていることです。

 （しかし、そもそも、A10行目以降にデータはあるのですか？）

 ただ、ちょっと気になるところもあります。コードを以下にして試すとどうなりますか？

 Private Sub CommandButton1_Click()

    Dim fPath As String
    Dim fName As String
    Dim reg As Object
    Dim c As Range
    Dim r As Range

    fName = "BB"

    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not .Show Then Exit Sub      'キャンセルボタン
        fPath = .SelectedItems(1) & "\" & fName & ".txt"
    End With

    If Dir(fPath) = "" Then
        MsgBox "このフォルダには指定のファイルがありません"
        Exit Sub
    End If
    '//取り込み前にシートのセルをクリア
    ActiveSheet.Cells.ClearContents
    '//エクセルの外部データ（テキストファイル）取り込み機能
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fPath, Destination:=Range("$A$1"))
        .Name = fName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        .Delete
    End With

    Application.ScreenUpdating = False

    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "(\s{3,}|-{3,})"    '★
    reg.Global = True

    Set r = Range("A10", Range("A" & Rows.Count).End(xlUp))

    For Each c In r.Cells
        c.Value = reg.Replace(c.Value, vbTab)
    Next

    r.Cells.TextToColumns Destination:=r.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True

    r.Value = Application.Trim(r.Value)

 End Sub

（β） 2015/03/19(木) 21:13

上手くいきました！
有難うございます。

最初に提示していただいたものだと、毎回一度A列に全て展開して、そのあと警告メッセージで上書きしてもいいですか？みたいなメッセージが出てOKをおさないと分割してくれなかったのですが、再度提示いただいたものだと警告メッセージ等も無く、スムーズに分割してくれました。
（yuko） 2015/03/20(金) 13:13

いらないところのスペースは消えているのですが、展開すると値が入る列が大きく広がってしまうのはなぜでしょう？
（yuko） 2015/03/20(金) 13:19

 実際にはセル幅はかわっていないはずです。（エクセルシートの列記号行を見ればかわっていないことがわかると思います）
 実際は連続したセルに分割されず、とびとびのセルに分割されてませんか？
 それで、そう見えてしまうんだと思います。

 でも、さて、どうするか・・・悩みますね。
 そもそもが、3文字以上の連続したスペースはセル区切りにするということと、そうしてもなお、余分なスペースがあるということは
 1文字のスペースないしは2文字のスペース。

 テキストファイルを取り込んだ後、とにかくスペースはすべて空白にしてしまうと、強引にやればいいのですが
 それだと、3文字以上のスペースも消えてしまうので、本来ならセル区切りになるべきところ、そうならない・・・

 ちょっと悩んでみますね。

（β） 2015/03/20(金) 13:50

 いったん泣き言を書き込みましたが、泣かなくて（？）すむことがわかったので改訂コードをアップします。

 Private Sub CommandButton1_Click()

    Dim fPath As String
    Dim fName As String
    Dim reg As Object
    Dim c As Range
    Dim r As Range

    fName = "BB"

    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not .Show Then Exit Sub      'キャンセルボタン
        fPath = .SelectedItems(1) & "\" & fName & ".txt"
    End With

    If Dir(fPath) = "" Then
        MsgBox "このフォルダには指定のファイルがありません"
        Exit Sub
    End If
    '//取り込み前にシートのセルをクリア
    ActiveSheet.Cells.ClearContents
    '//エクセルの外部データ（テキストファイル）取り込み機能
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fPath, Destination:=Range("$A$1"))
        .Name = fName
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False          '★
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        .Delete
    End With

    Application.ScreenUpdating = False

    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "(\s{3,}|-{3,})"    '★
    reg.Global = True

    Set r = Range("A10", Range("A" & Rows.Count).End(xlUp))

    For Each c In r.Cells
        c.Value = reg.Replace(Trim(c.Value), vbTab)
    Next

    r.Cells.TextToColumns Destination:=r.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True

    With ActiveSheet.UsedRange
        .Value = Application.Trim(.Value)
    End With

 End Sub

（β） 2015/03/20(金) 14:30

開くファイル名を変更してからまた展開するときに
コピーまたは移動先のセルの内容を書き換えますか
という警告文がでるのですが、これを出さなくする方法はありますか？
（yuko） 2015/03/20(金) 15:13

 シート上で区切り文字の分割操作、試してみましたか？

（β） 2015/03/19(木) 21:13 で、おすすめしていますが。

 で、シート上で操作したとき、分割する値が入る右の法のセルがからっぽならメッセージはでませんが
 そこに何か、はいっていると、上書きされますから、それで、ほんとにいいの？　と聞いてくれているんです。

 そもそも、そこには、何か入っているのですか？

 いずれにしても、このメッセージの抑止をするなら、r.Cells.TextToColumns の　上あたりに
 Application.DisplayAlerts = False を1行、いれておいてください。

（β） 2015/03/20(金) 15:53

それは試しました！
分割する様子は確認できました。
教えていただき有難うございます。

また、B列が空欄の状態ではありませんでした。。。
一度試したものの上から試していた為だとわかりました。。。
失礼しました。

今までテストで適当にテキストファイルを作って試していましたが、実際に使用するファイルを展開しようとすると必ず固まってしまいます。。。
使用するファイルには様々な記号(/や&や*や@など)が含まれています。
また、頭にスペースが来るものもあります。その中にはスペースが3つ以上連続されているものもあります。
(当初ないと言っていましたがありました。。。ごめんなさい！！！)

これらが原因なのでしょうか？

（yuko） 2015/03/20(金) 16:09

●「必ず固まってしまいます」

 この【固まる】というのは、どういう状況でしょうか？

 まず、（β） 2015/03/20(金) 14:30 にアップしたコードは、おおよそ、以下の順序で処理を行っています。

 １）指定フォルダに BB.txtがあればそれをエクセルのテキストファイル取り込み機能で【そのまま】
　　マクロブックの一番目のシートに取り込む。
 ２）結果、Ａ列に取り込まれた状態。
 ３）次に、A10～A列最後のデータまで以下をループ処理。

 　　・そのセルの値の先頭と末尾のスペースをVBA関数のTrimを使って削除。
 　　・削除されたものに対して、空白3個以上連続のものや、- 3個以上連続のものを 1文字の特殊文字(タブ記号)に置き換える。
 　　　（タブ記号は、おそらく、取り込んだデータの中には存在しないだろうと思われる文字ということで使っています）

 ４）で、このA10～A列最後のデータまでをエクセルの区切り文字記号（分割文字にはタブ記号を指定）機能を使いセルに分割。
 ５）最後に、シートの領域全体に対して、今度はエクセル関数のTrimで文字列中に連続した2桁以上のスペースを1桁に変換。

 ですから、

 >使用するファイルには様々な記号(/や&や*や@など)が含まれています。

 - や スペース　以外は、A や B や、あ や い や 1 や 2 と同じ、単なる文字ですから、
 これらあがあるから処理がおかしくなるということは考えられません。

 >頭にスペースが来るものもあります。その中にはスペースが3つ以上連続されているものもあります。

 上の３）で説明しましたが、処理前に、これは、取り除かれますから問題はありません。

（β） 2015/03/20(金) 17:53

展開用のボタンを押すと、A1列から正しく展開されているように見えるのですが、スクロールができず、ほかのボタンも動作せず、excelを閉じようとするとタスクの終了をしないと閉じれません。

（yuko） 2015/03/20(金) 19:12

 う～ん・・・何か、テキストファイルの取り込み機能で足をひっぱっているのでしょうかね？
 （βは、あまり詳しくないので・・・）

 ｃｓｖファイルの取り込み方法はいくつもあるんだけど、その中で、最も、どんくさく、効率も悪いけど
 無難なところで、ワークブックとして開く方法に切り替えるとどうなりますか？

 Private Sub CommandButton1_Click()

    Dim fPath As String
    Dim fName As String
    Dim reg As Object
    Dim c As Range
    Dim r As Range
    Dim csv As Worksheet
    Dim mySh As Worksheet

    Set mySh = ActiveSheet
    fName = "BB"

    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not .Show Then Exit Sub      'キャンセルボタン
        fPath = .SelectedItems(1) & "\" & fName & ".txt"
    End With

    If Dir(fPath) = "" Then
        MsgBox "このフォルダには指定のファイルがありません"
        Exit Sub
    End If

    Application.ScreenUpdating = False

    '//取り込み前にシートのセルをクリア
    mySh.Cells.ClearContents
    'Csvファイルをブックとして開き、マクロブックにコピペ
    Set csv = Workbooks.Open(fPath).Sheets(1)
    csv.Range("A1", csv.Range("A" & Rows.Count).End(xlUp)).Copy mySh.Range("A1")
    csv.Parent.Close False

    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = "(\s{3,}|-{3,})"    '★
    reg.Global = True

    Set r = Range("A10", Range("A" & Rows.Count).End(xlUp))

    For Each c In r.Cells
        c.Value = reg.Replace(Trim(c.Value), vbTab)
    Next

    r.Cells.TextToColumns Destination:=r.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True

    With ActiveSheet.UsedRange
        .Value = Application.Trim(.Value)
    End With

 End Sub

（β） 2015/03/20(金) 19:49

今度は展開する前にexcelが動かなくなってしまいました。。。
（yuko） 2015/03/20(金) 20:33

 それは、何か別の原因かも。

 ＰＣをシャットダウン、リブートしてみてください。

（β） 2015/03/20(金) 20:35

連絡が遅くなりました
ごめんなさい

パソコンも再起動して元々提示していただいたものと、最後のパターン両方試しましたが、現象はどちらもかわりませんでした・・・
（yuko） 2015/03/23(月) 09:58

試しにスペース3個以上で～というところは省き、一番初めに教えていただいた、フォルダを選択し、excelに展開する、という処理だけだと上手くいきました！
（yuko） 2015/03/23(月) 10:10

 まったく確証はないのですが、テキスト内にゴミ（Ｗｅｂから貼り付けた場合等）があるケースで
 文字列処理で永久ループに陥る等いう現象が別スレであり、(マナ)さんが、その可能性に思い当り
 文字列処理の前に、そのゴミを取り除くことで、正常終了という事例がありました。

 たとえば　（β） 2015/03/20(金) 19:49　のコードの　最後の部分を

    MsgBox "A"

    For Each c In r.Cells
        c.Value = reg.Replace(Trim(c.Value), vbTab)
    Next

    MsgBox "B"

    r.Cells.TextToColumns Destination:=r.Cells(1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=vbTab, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
            Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
            TrailingMinusNumbers:=True

    MsgBox "C"

    With ActiveSheet.UsedRange
        .Value = Application.Trim(.Value)
    End With

    MsgBox "D"

 End Sub

 このように置き換えて、メッセージがどこまで出るか、試してもらえませんか。

（β） 2015/03/23(月) 17:15

”C”までは表示されました
excel上には何も展開されず、Cまで表示されてexcelが停止しました
（yuko） 2015/03/23(月) 18:00

 確認ありがとう。
 まったく自信ないですが、もし「ゴミ」が影響しているなら、以下でごみそうじを。

    With ActiveSheet.UsedRange
        .Value = Application.Trim(.Value)
    End With

 これを

    With Intersect(r.EntireRow, ActiveSheet.UsedRange)
        For Each c In .Cells
            c.Value = WorksheetFunction.Trim(Replace(c.Value, ChrW(160), ""))
        Next
    End With

 こうして試してみてください。

（β） 2015/03/23(月) 19:10

流れをよく理解できていませんが、
最後に不要なスペースを除くことが残された課題ですか？

 msgbox ”C"までOKであれば、こんな流れでいけそうな気がするのですが。

 １）３続スペースをvbTabに置換
 ２）２連続スペースを１個のスペースに置換
 ３）TextToColumns実行
 ４）VBAのTrim実行

 問題の原因と思われるデータを１行に絞ってもらって
 yukoさん以外でも再現できるデータを提示してもらえると解決が早いのですが。

 上の問題と関係ないのですが、TextToColumnsの引数はこれくらいでもよいかもしれません。
 Tabがダブって指定されているのが気になっちゃいます。

 r.Cells.TextToColumns _
	Destination:=r.Cells(1), _
	DataType:=xlDelimited, _
	ConsecutiveDelimiter:=True, _
	Tab:=True

（マナ） 2015/03/23(月) 23:33

 最初は、固まる原因が、UsedRangeの大きさかなぁと、思ったんですが、それであれば、固まるのではなく
 メモリーが不足しています　といったエラーが表示されるだろうなと。

 Sub TestAtoZ()
    Cells.Clear
    Range("A1").Value = "A"
    Cells(Rows.Count, Columns.Count).Value = "Z"
    With ActiveSheet.UsedRange
        .Value = Application.Trim(.Value)
    End With
 End Sub

 なので、「ゴミ」かなぁと。

 いずれにしても、 (マナ)さんの提示処理順を見て、はたと気が付いたのですが、

 c.Value = reg.Replace(Trim(c.Value), vbTab)

 ここで、先頭と末尾のスペースの削除と３連続以上のスペースの vbTab変換は処理済みなので
 残る（ほんとうにあるのかどうかわかりませんが）文字列中の２連続スペースを１桁スペースにしてやれば
 最後の、

    With ActiveSheet.UsedRange
        .Value = Application.Trim(.Value)
    End With

 これそのものが不要になりますね。

 これを消してしまって

 c.Value = reg.Replace(Trim(c.Value), vbTab)

 これを

 C.Value = WorkSheetFunction.Trim(reg.Replace(Trim(c.Value), vbTab))

 こうすると、どうでしょうね。

 なお、TextToColumns の引数については、(マナ)さんの助言のようになおしてください。

（β） 2015/03/24(火) 04:01

うまく展開できました！
有難うございます！！
本当に助かりました。
（yuko） 2015/03/24(火) 11:49

コメント返信：

[ 一覧(最新更新順) ]

[[20150317202709]] 『様々なフォルダ内で同じ名前のファイルを自動的に』（yuko） ページの最後に飛ぶ

[[20150317202709]]　『様々なフォルダ内で同じ名前のファイルを自動的に』（yuko）　ページの最後に飛ぶ