[[20230314170420]]　『格納先についてご相談』（つつ）　ページの最後に飛ぶ

『格納先についてご相談』（つつ）

マクロについて質問です。番号によってフォルダを振り分けたいです。
番号がAAW0001であれば、
「\\A\B\C\w番号\0-1000\0-100\」ここに格納したい。
100毎は下記で問題ないですが1000毎がうまくいかず。
フォルダは既に作成してます。
ご教示お願いいたします。

x = "\\A\B\C\"

k = Mid(番号, 3, 1)
n = Mid(番号, 4, 4)

If n <= 100 Then
Spass = x & k & "番号\0-100\" & 番号
ElseIf n <= 200 Then
Spass = x & k & "番号\101-200\" & 番号
ElseIf n <= 300 Then
Spass = x & k & "番号\201-300\" & 番号
ElseIf n <= 400 Then
Spass = x & k & "番号\301-400\" & 番号
ElseIf n <= 500 Then
Spass = x & k & "番号\401-500\" & 番号
ElseIf n <= 600 Then
Spass = x & k & "番号\501-600\" & 番号
ElseIf n <= 700 Then
Spass = x & k & "番号\601-700\" & 番号
ElseIf n <= 800 Then
Spass = x & k & "番号\701-800\" & 番号
ElseIf n <= 900 Then
Spass = x & k & "番号\801-900\" & 番号
ElseIf n <= 999 Then
Spass = x & k & "番号\901-999\" & 番号
End If

以上よろしくお願いいたします。

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

 問いとコードが一致してない気がするけど、
 0001なら　 \\A\B\C\w番号\0-1000\0-100\
 1001なら　 \\A\B\C\w番号\1001-2000\0-100\
 でいいのかしら？

 個人的に桁がそろってないと気持ち悪いので
 \\A\B\C\w番号\0001-1000\001-100\
 のようなフォルダのほうがいい気がするんだけど・・・
（稲葉） 2023/03/14(火) 17:20:48

 桁揃えと繰り上がりを0にするのか1にするのか揃えたほうがコーディング簡単だけど
 指定されたフォルダ構成であれば、以下の形でどうでしょうか？
    Sub test()
        Dim spass As String
        Dim n As String
        Dim 番号 As String
        Dim fp親 As String
        Dim fp子 As String
        番号 = "AAW9111"
        spass = "\\A\B\C\" & Mid(番号, 3, 1) & "番号\"

        n = Mid(番号, 4, 4)
        '1000番台フォルダ
        Select Case Left(n, 1)
        Case "0"
            fp親 = "0-1000\"
        Case "9"
            fp親 = "9001-9999\"
        Case Else
            fp親 = Left(n, 1) & "001-" & Left(n, 1) + 1 & "000\"
        End Select

        '100番台フォルダ
        Select Case Mid(n, 2, 1)
        Case "0"
            fp子 = "0-100\"
        Case "9"
            fp子 = "901-999\"
        Case Else
            fp子 = Mid(n, 2, 1) & "01-" & Mid(n, 2, 1) + 1 & "00\"
        End Select
        spass = spass & fp親 & fp子
        Stop
    End Sub
（稲葉） 2023/03/14(火) 17:40:29

 問いとコードが一致してない気がするけど、
 0001なら　 \\A\B\C\w番号\0-1000\0-100\
 1001なら　 \\A\B\C\w番号\1001-2000\0-100\
 でいいのかしら？
⇒大変失礼しました。相違ないです。

 個人的に桁がそろってないと気持ち悪いので
 \\A\B\C\w番号\0001-1000\001-100\
 のようなフォルダのほうがいい気がするんだけど・・・
⇒おっしゃる通り0001のほうがまとまりいいですね。
（つつ） 2023/03/14(火) 17:59:47

 \\A\B\C\w番号\0000-0999\000-099\
 \\A\B\C\w番号\0000-0999\100-199\
 こういう繰り上がりなら、SelectCase入れないで
 fp親 = Left(n, 1) & "000-" & Left(n, 1) & "999\"
 fp子 = Mid(n, 2, 1) & "00-" & Mid(n, 2, 1) & "99\"
 これだけで済みそうです
（稲葉） 2023/03/14(火) 18:05:37

すみません。
ちょっと理解ができなくなったので、一度すべて記載するので、

 \\A\B\C\w番号\0000-0999\000-099\
 \\A\B\C\w番号\0000-0999\100-199\
こういう形で問題ないので、再度作成していただけないでしょうか？

Public Sub 帳票保存処理()

    Dim k, Spass, x As String, i, j, n As Integer
    Dim F(13) As String

    F(0) = file1: F(1) = file2: F(2) = file3

    For i = 1 To 5 Step 1
        F(i + 2) = 購入先ブック(i)
    Next i

    F(8) = file5: F(9) = file6: F(10) = file7: F(11) = file8: F(12) = file9: F(12) = file10

    x = "\\A\B\C\D\E\"

    k = Mid(製番, 3, 1)
    n = Mid(製番, 4, 4)

    If n <= 100 Then
        Spass = x & k & "製番\0-100\" & 製番
    ElseIf n <= 200 Then
        Spass = x & k & "製番\101-200\" & 製番
    ElseIf n <= 300 Then
        Spass = x & k & "製番\201-300\" & 製番
    ElseIf n <= 400 Then
        Spass = x & k & "製番\301-400\" & 製番
    ElseIf n <= 500 Then
        Spass = x & k & "製番\401-500\" & 製番
    ElseIf n <= 600 Then
        Spass = x & k & "製番\501-600\" & 製番
    ElseIf n <= 700 Then
        Spass = x & k & "製番\601-700\" & 製番
    ElseIf n <= 800 Then
        Spass = x & k & "製番\701-800\" & 製番
    ElseIf n <= 900 Then
        Spass = x & k & "製番\801-900\" & 製番
    ElseIf n <= 999 Then
        Spass = x & k & "製番\901-999\" & 製番
    End If

    On Error Resume Next
        MkDir Spass
    If Err.Number = 75 Then
        On Error GoTo 0
    End If

    Spass = Spass & "\" & Left(rist(0), Len(rist(0)) - 4)

    On Error Resume Next
        MkDir Spass
    If Err.Number = 75 Then
        On Error GoTo 0
    End If

    For i = 0 To 12 Step 1
        On Error Resume Next
        Windows(F(i)).Activate

        If Err.Number <> 0 Then
            On Error GoTo 0
            GoTo jump
        End If

        ChDir Spass
        On Error Resume Next
        ActiveWorkbook.SaveAs Filename:= _
            Spass & "\" & F(i), FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
jump:
    Next i

    MsgBox "保存を実行された場合は、" & Spass & " に保存されています。", vbInformation

    Windows(file0).Close savechanges:=False

    End
End Sub

（つつ） 2023/03/14(火) 18:13:57

 少しやり直したけど、こんな具合でいかがでしょう？
    Public Sub 帳票保存処理()
        Dim k As String, Spass As String, i As Long, j As Long
        Dim F(13) As String
        F(0) = file1: F(1) = file2: F(2) = file3
        For i = 1 To 5 Step 1
            F(i + 2) = 購入先ブック(i)
        Next i
        F(8) = file5: F(9) = file6: F(10) = file7: F(11) = file8: F(12) = file9: F(12) = file10

        '[フォルダパス生成]
        Const x As String = "\\A\B\C\"
        Dim n As String, fp親 As String, fp子 As String

        '//型番？抜き出し
        k = Mid(製番, 3, 1) & "番号\"

        '//整理番号？抜き出し
        n = Mid(製番, 4, 4)

        '//1000番台フォルダ　0000-0999\
        fp親 = Replace("<桁>000-<桁>999\", "<桁>", Left(n, 1))

        '//100番台フォルダ 　000-099\
        fp子 = Replace("<桁>00-<桁>99\", "<桁>", Mid(n, 2, 1))

        '//フォルダパス　\\A\B\C\w番号\0000-0999\000-009\
        Spass = x & k & fp親 & fp子
        Stop

        On Error Resume Next
            MkDir Spass
        If Err.Number = 75 Then
（稲葉） 2023/03/14(火) 18:28:38

稲葉様

出来た気がします！！
ありがとうございました！！

いろいろ試してみます！！！
（つつ） 2023/03/15(水) 09:11:43

コメント返信：

[ 一覧(最新更新順) ]

[[20230314170420]] 『格納先についてご相談』（つつ） ページの最後に飛ぶ

[[20230314170420]]　『格納先についてご相談』（つつ）　ページの最後に飛ぶ