[[20150312153202]]　『VBAでのＢＯＯＫのリネームについて』（katanohosi）　ページの最後に飛ぶ

『VBAでのＢＯＯＫのリネームについて』（katanohosi）

日付+県名+件数.xlsxが最大で32県、その日によってはばらつきがあります。
このBOOK名を県名.xlsxにしたく下記を作成したのですが、
存在しない県名のBOOKがあるとエラーで止まります。
流れを追うと、該当がないときはそのまま
ActiveWorkbook.SaveAs Filename:=Zippath & ken(i) & Ekaku
ActiveWorkbook.Close
を実行しようとするからみたいです。
該当がない場合はスルーさせたいのですが、どなたか教えてください。
よろしくお願いいたします。

Sub リネーム()

  Dim apath As Variant
  Dim Houpath As Variant
  Dim Zippath As Variant
  Dim myFile As Variant
  Dim strWorkBookName As Variant
  Dim sikaku As Variant
  Dim Ekaku As Variant
  Dim ken(32) As Variant   '変数kenは整数型宣言1から32まで宣言するので、最後の数字を入れればＯＫ
  Dim i As Integer
  Dim siteibi As Variant
  Dim ken As Variant

  ken(1) = "大阪"
  ken(2) = "和歌山"
  ken(3) = "京都"
  ken(4) = "滋賀"
  ken(5) = "奈良"
  ken(6) = "兵庫_神戸"
  ken(7) = "兵庫_姫路"
  ken(8) = "愛知_名古屋"
  ken(9) = "愛知_三河"
  ken(10) = "岐阜"
  ken(11) = "三重"
  ken(12) = "静岡"
  ken(13) = "石川"
  ken(14) = "富山"
  ken(15) = "福井"
  ken(16) = "広島"
  ken(17) = "島根"
  ken(18) = "岡山"
  ken(19) = "鳥取"
  ken(20) = "山口"
  ken(21) = "愛媛"
  ken(22) = "香川"
  ken(23) = "徳島"
  ken(24) = "高知"
  ken(25) = "福岡"
  ken(26) = "佐賀"
  ken(27) = "長崎"
  ken(28) = "熊本"
  ken(29) = "大分"
  ken(30) = "鹿児島"
  ken(31) = "宮崎"
  ken(32) = "沖縄"

  apath = ThisWorkbook.Path
  Houpath = apath & "\20150310\"
  Zippath = apath & "\圧縮\"
  sikaku = ".XLSX"
  Ekaku = ".xlsx"
  siteibi = ThisWorkbook.Sheets(1).Range("AN33")
  ken = "*" & ken(i) & "*"

 Application.ScreenUpdating = False

  ChDir ThisWorkbook.Path
  For i = 1 To 32
    With CreateObject("Scripting.FileSystemObject").Getfolder(Houpath)
          For Each myFile In .Files
            If myFile.Name Like "*" & ken(i) & "*" & sikaku Then
              With Workbooks.Open(Filename:=myFile.Path, Password:="1234")
                strWorkBookName = ActiveWorkbook.Name  '今開いたファイルの名前を取得　"*●●*.xlsx"
                    End With
                    Exit For
                    End If
            Next myFile
    End With
     ActiveWorkbook.SaveAs Filename:=Zippath & ken(i) & Ekaku
     ActiveWorkbook.Close
  Next

End Sub

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

 自分で書いたコードなのかな？
 １行１行何をやっているか理解すれば解かると思いますよ。
 もう少し頑張ってみては。
 BJ

 BJさんのご意見を尊重して・・・
 一言だけ
 せっかくIfで条件判定しているのだから、その処理も加えてみたらどうでしょうか？

 というか、総当たりの順番逆じゃない？

（稲葉） 2015/03/12(木) 15:58

(katanohosi)

BJさん　稲葉さん
ありがとうございます！！
初心者から脱せず頭が煮えきってました。
冷静に考えたら下記のように修正すればＯＫでした。
もっと冷静に考えるべきでした；
ところで、稲葉さんの「総当たりの順番逆じゃない？」
はどこの部分になりますでしょうか。
すみません、教えていただければありがたいです。

　Application.ScreenUpdating = False

  ChDir ThisWorkbook.Path
  For i = 1 To 32
    With CreateObject("Scripting.FileSystemObject").Getfolder(Houpath)
          For Each myFile In .Files
            If myFile.Name Like "*" & ken(i) & "*" & sikaku Then
              With Workbooks.Open(Filename:=myFile.Path, Password:="1234")
                strWorkBookName = ActiveWorkbook.Name  '今開いたファイルの名前を取得　"*●●*.xlsx"
                ActiveWorkbook.SaveAs Filename:=Zippath & ken(i) & Ekaku
                ActiveWorkbook.Close
                    End With
                    Exit For
                    End If
            Next myFile

    End With
  Next
    MsgBox "リネームが終了しました。圧縮してください。"

 ちょっと書いている間に、だいぶ話が進んでいるようですが、
 せっかく書いたので、参考までの修正案です。

 Sub リネーム()
    Dim 県リスト
    県リスト = Array( _
        "大阪", "和歌山", "京都", "滋賀", "奈良", "兵庫_神戸", "兵庫_姫路", "愛知_名古屋", "愛知_三河", "岐阜", _
        "三重", "静岡", "石川", "富山", "福井", "広島", "島根", "岡山", "鳥取", "山口", _
        "愛媛", "香川", "徳島", "高知", "福岡", "佐賀", "長崎", "熊本", "大分", "鹿児島", _
        "宮崎", "沖縄")

    Dim データフォルダ
    データフォルダ = ThisWorkbook.Path & "\20150310"

    Dim 圧縮フォルダ
    圧縮フォルダ = ThisWorkbook.Path & "\圧縮\"

    Application.ScreenUpdating = False

    Dim ファイル
    Dim 県名
    For Each ファイル In CreateObject("Scripting.FileSystemObject").Getfolder(データフォルダ).Files
        For Each 県名 In 県リスト
            If ファイル.Name Like "*" & 県名 & "*.xlsx" Then
                With Workbooks.Open(Filename:=ファイル.Path, Password:="1234")
                    .SaveAs Filename:=圧縮フォルダ & 県名 & ".xlsx"
                    .Close
                End With
                Exit For
            End If
        Next
    Next
    Application.ScreenUpdating = True
 End Sub

（Mook） 2015/03/12(木) 16:39

Mookさん

ありがとうございます。
リストを配列で作成すると　こんなにスッキリするんですね。
こんな上級な方法があるんですね。
凄いです！
それから、変数など日本語で書くと他の人にも凄くわかりやすいですね。
早速使わせていただきます。
まだまだネットで調べてつぎはぎをやっているので、いろいろなパターンを知ることができると
すごくありがたいです。

（katanohosi） 2015/03/12(木) 16:46

 総当たりの順番ですが、Mookさんの修正案に丸ごと入ってます。
 県名の配列の中で、ブック名を回すのではなく
 ブック名の中で、県名の配列を回すほうが
 後から見たときわかりやすいかなと。
（稲葉） 2015/03/12(木) 16:49

稲葉さん

コメントありがとうございます。
もっとスキルが上がるよう頑張ります。
（katanohosi） 2015/03/12(木) 17:14

 前似たようなもの作った記憶があって掘り出したので、参考出品
 比較しやすいように、Mookさんの変数名に合わせてあります。
    Sub リネーム2()
        Dim 県リスト As String
        Dim データフォルダ
        Dim 圧縮フォルダ
        Dim ファイル
        県リスト = "大阪|和歌山|京都|滋賀|奈良|兵庫_神戸|兵庫_姫路|愛知_名古屋|愛知_三河|岐阜|" & _
                   "三重|静岡|石川|富山|福井|広島|島根|岡山|鳥取|山口|愛媛|香川|徳島|高知|福岡|" & _
                   "佐賀|長崎|熊本|大分|鹿児島|宮崎|沖縄"
        データフォルダ = ThisWorkbook.Path & "\20150310"
        With CreateObject("VBScript.RegExp")
            .Pattern = "(" & 県リスト & ")"
            For Each ファイル In CreateObject("Scripting.FileSystemObject").Getfolder(データフォルダ).Files
                If .Text(ファイル.Name) Then
                    ブックの保存 ファイル.Path, .Execute(ファイル.Name)(0)
                    Exit For
                End If
            Next ファイル
        End With
    End Sub
    Private Sub ブックの保存(ByVal ファイルパス As String, ByVal 県名 As String)
        Application.ScreenUpdating = False
        With Workbooks.Open(Filename:=ファイルパス, Password:="1234")
            .SaveAs Filename:=ThisWorkbook.Path & "\圧縮\" & 県名 & ".xlsx"
            .Close
        End With
    End Sub
（稲葉） 2015/03/12(木) 17:16

 稲葉さん

 ありがとうございます。
 上級の方々が作ると似たようであっても、違う作りができるんですね。
 初めて見る記載があって「With CreateObject("VBScript.RegExp")」今ネットでいろいろ検索しています。
 本当に勉強になります。
 これが解るまで少し時間がかかりそうです；

 確認不足で質問して恥ずかしかったですが、新しいことを知ることができて良かったと思っています。

 ありがとうございました。
（katanohosi） 2015/03/13(金) 09:38

コメント返信：

[ 一覧(最新更新順) ]

[[20150312153202]] 『VBAでのＢＯＯＫのリネームについて』（katanohosi） ページの最後に飛ぶ

[[20150312153202]]　『VBAでのＢＯＯＫのリネームについて』（katanohosi）　ページの最後に飛ぶ