[[20211114092753]]　『条件分岐の方法』（BPA）　ページの最後に飛ぶ

『条件分岐の方法』（BPA）

転記元のシート1のA列に氏名コートが６桁あり、
アタマ２桁が、75だったら、転記先のデータ2シートへ転記、
アタマ２桁が、72だったら、転記先のデータ3シートへ転記
それ以外は、データ1シートに転記を行うプログラムを考えています。

条件分岐の記載方法がわからず、困っています。
教えて頂けないでしょうか。

Sub 転記_Click()

   Dim wb As Workbook
   Dim sh1,sh2 As Worksheet
   Dim Rout As Long

   Dim FileName As String

   FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
   Rout = 7

   Do While FileName <> ""
     If FileName <> ThisWorkbook.Name Then

     Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)

     Set sh1 = Workbooks.Worksheets("シート1")
     Set sh2 = Workbooks.Worksheets("シート2")

     For Each sh1,sh2 In wb.Worksheets

     If　left(sh1.Range(Rout, "A"), 2)=75 Then

     With ThisWorkbook.Worksheets("データ2")

         .Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
         .Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
         .Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
         .Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
         .Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
         .Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value

   End With

      Rout = Rout + 1

     If　left(sh1.Range(Rout, "A"), 2)=72 Then

     With ThisWorkbook.Worksheets("データ3")

         .Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
         .Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
         .Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
         .Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
         .Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
         .Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value

   Else

     With ThisWorkbook.Worksheets("データ1")

         .Cells(Rout+1, "B").Value = sh1.Range(Rout, "A").Value
         .Cells(Rout+1, "C").Value = sh1.Range(Rout, "F").Value
         .Cells(Rout+1, "D").Value = sh1.Range(Rout, "B").Value
         .Cells(Rout+1, "E").Value = sh1.Range(Rout, "G").Value
         .Cells(Rout+1, "F").Value = sh1.Range(Rout, "AA").Value
         .Cells(Rout+1, "G").Value = sh2.Range(Rout, "AA").Value

  End If

    wb.Close False

  End If
   FileName = Dir

  Loop

 MsgBox "処理終了"

End Sub

＜使用 Excel：Excel2019、使用 OS：Windows8 ＞

 おはよ～ございます　＾＾
いろいろ、方法は有るかと思いますが一案で。＾＾；
コード、よく見て無いので。。。その。なんですが
Select Case 頭の二文字
    Case "72"
        72の時の処理
    Case "75"
        75の時の処理
    Case Else
        それ以外の処理
End Select
とかでも
同じような内容なら、サブルーチンで引数を渡し、72,75、他
の処理を分けるとかも、よいかもですね。
詳細は検索していただくと、懇切丁寧な説明サイトがたくさんありますよ。
（隠居Z） 2021/11/14(日) 10:00

 あれ？。。。＾＾；
[[20211114090213]]と同じ方でしたら
どちらかで
纏めてご質問された方が、回答者の皆様も解りやすいかと。
（隠居Z） 2021/11/14(日) 11:22

一部、隠居Zさんのコメントとかぶる部分もありますが、他も含めて何点か。

■１
偶然なのかもしれませんが、↓の方と同じ失敗をしているところがありますので、まずはそこを修正されるとよいでしょう。
[[20211114090213]]　『フォルダ内のエクセルを選択し、選択したエクセルデータを転記するプログラム』（P）

 For Each sh1,sh2 In wb.Worksheets

 Set sh1 = Workbooks.Worksheets("シート1")
 Set sh2 = Workbooks.Worksheets("シート2")

■２
どうでもいい部分を除くと↓のようになってます。

    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
        For Each sh In wb.Worksheets'■１を修正したとして
            If Left(sh1.Range(Rout, "A"), 2) = 75 Then
                With ThisWorkbook.Worksheets("データ2")
                End With

                Rout = Rout + 1
                If Left(sh1.Range(Rout, "A"), 2) = 72 Then
                    With ThisWorkbook.Worksheets("データ3")
                Else
                    With ThisWorkbook.Worksheets("データ1")
                End If

                wb.Close False
            End If
            FileName = Dir
        Loop

これを↓のように修正すべきでしょう。

    Rout = 7
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & FileName, False, True)

            For Each sh In wb.Worksheets '■１を修正したとして
                If Left(sh1.Range(Rout, "A"), 2) = 75 Then
                    With ThisWorkbook.Worksheets("データ2")
                    End With

                    Rout = Rout + 1
                    If Left(sh1.Range(Rout, "A"), 2) = 72 Then
                        With ThisWorkbook.Worksheets("データ3")
                        End With  '★追加
                    Else
                        With ThisWorkbook.Worksheets("データ1")
                        End With  '★追加
                    End If
                End If '★「If Left(sh1.Range(Rout, "A"), 2) = 75」に対するEnd If を追加
            Next sh '★「For Each sh In wb.Worksheets」に対するNextを追加

            wb.Close False
        End If

        FileName = Dir
    Loop

■３
「■２」のように修正したとして、すべて↓の条件ありきになっているわけです。

 If Left(sh1.Range(Rout, "A"), 2) = 75

やりたいことはそうではないですよね？
したがって↓のような形にすべきでしょう。

    If Left(sh1.Range(Rout, "A"), 2) = 75 Then
        'データ2へ転記

    ElseIf Left(sh1.Range(Rout, "A"), 2) = 72 Then
        'データ3へ転記

    Else
        'データ1へ転記
    End If

 または
    Select Case Left(sh1.Range(Rout, "A").Value, 2)
        Case "75"
            'データ2へ転記

        Case "72"
            'データ3へ転記

        Case Else
            'データ1へ転記
    End Select

■４
さらに↓もおかしいですよ。

 Rout = Rout + 1

これだと、書き込む行も読み込む行もどんどんずれていくので、データもとのブックに１行しかないのであっても、読み込む行の開始位置がおかしなことになりますよ。
さらに、書き込む行もシートが振り分けられるのですから、１行書き込んだら１行ずらせば済む問題ではありません。

■５
以上を踏まえると

 (1)  自ブック側に作業用シートを用意する

 (2)  データもとのブックを開く

 (3)  フィルタオプションで(2)の対象シートから750000～759999のデータを【抽出】する
 (4)  (3)を対象シートの最終行+1のところに貼付する

 (5)  フィルタオプションで(2)の対象シートから720000～729999のデータを【抽出】する
 (6)  (5)を対象シートの最終行+1のところに貼付する

 (7)  フィルタオプションで(2)の対象シートから、750000～759999、720000～729999以外のデータを【抽出】する
 (8)  (7)を対象シートの最終行+1のところに貼付する

 (9)  データもとのブックを保存せずに閉じる

 (2)～(9)をブックの数だけ繰り返す

というアプローチでも対応可能かとおもいますので、研究されてみてはいかがでしょうか。

（もこな２） 2021/11/14(日) 11:24

コメント返信：

[ 一覧(最新更新順) ]

[[20211114092753]] 『条件分岐の方法』（BPA） ページの最後に飛ぶ

[[20211114092753]]　『条件分岐の方法』（BPA）　ページの最後に飛ぶ