[[20210521231309]]　『転記について』（u）　ページの最後に飛ぶ

『転記について』（u）

こんばんは
以前隠居じーさん様にご教授いただいたコードで
コードの内容を自分なりに理解しようとしていますが
理解できずに困っています。
コードは

 Dim zTb           As Workbook
    Dim i             As Long
    Dim j             As Long
    Dim k             As Long
    Dim n             As Long
    Dim v()           As Variant
    Dim tMp()         As Variant
    Dim iDx()         As Variant
    Dim leadB         As Workbook
    Dim beforeB       As Workbook
    Dim x             As Variant
    Dim fNmTx         As String
    Dim fNmBk         As String
    Dim dAtaBk        As Variant
    Dim rr            As Range
    Dim t             As Double
    t = Timer
    Set zTb = Workbooks(zProgramID)
    With zTb.Worksheets("機種間共通検索")
        v = .Range("D1:YC154").Value
    End With
    For i = 2 To UBound(v, 2) Step 13
        For j = 12 To UBound(v, 1)
            If v(j, i) <> "" Then
                ReDim tMp(1 To 3 + 2)
                tMp(1) = v(3, i - 1)
                tMp(2) = v(j, i)
                tMp(3) = v(j, i + 1)
                tMp(4) = v(7, i - 1)    '先行機種 上位品番
                tMp(5) = v(7, i)        '先行機種 投入工程
                ReDim Preserve iDx(n)
                iDx(n) = tMp
                n = n + 1
            End If
        Next
    Next
    n = 0
    For i = LBound(iDx) To UBound(iDx)
        fNmTx = ThisWorkbook.Path & "\" & iDx(i)(2) & ".xlsx"
        If zWbExists(fNmTx) Then
            Set leadB = Workbooks.Open(fNmTx)
            With leadB.Worksheets(1)
                Set rr = .Range("B6:AJ359")
                For k = 2 To rr.Rows.Count
                    If iDx(i)(4) = "" Then
                        If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) Then
                            n = rr(k, 1).Row
                        End If
                    Else
                        If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) And rr(k, 30) = iDx(i)(4) Then
                            n = rr(k, 1).Row
                        End If
                    End If
                Next
                If n > 0 Then
                    If iDx(i)(1) <> "" Then .Cells(n, "A") = iDx(i)(1)
                    fNmBk = iDx(i)(2)
                    dAtaBk = .Cells(n, "F").Value
                End If
                n = 0
            End With
            leadB.Close True
            Set rr = Nothing
            Set leadB = Nothing
        Else
            MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
            Exit For
        End If
        '前機種名
        If iDx(i)(1) <> "" Then
            fNmTx = ThisWorkbook.Path & "\" & iDx(i)(1) & ".xlsx"
            If zWbExists(fNmTx) Then
                Set beforeB = Workbooks.Open(fNmTx)
                With beforeB.Worksheets(1)
                    x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
                    If Not IsError(x) Then
                        If fNmBk <> "" Then
                            .Cells(x, "H") = fNmBk
                            fNmBk = ""
                        End If
                        If dAtaBk <> "" Then
                            .Cells(x, "C") = dAtaBk
                            dAtaBk = ""
                        End If
                    End If
                End With
                beforeB.Close True
                Set beforeB = Nothing
            Else
                MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
                Exit For
            End If
        End If
        If i Mod 30 = 0 Then DoEvents
    Next
    Set zTb = Nothing
    Erase v, iDx, tMp
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
    zWbExists = False
    If Dir(fp) <> "" Then zWbExists = True
End Function
（隠居じーさん） 2021/04/08(木) 08:59
で
理解に苦しんでいるのは
 For k = 2 To rr.Rows.Count
                    If iDx(i)(4) = "" Then
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(5) Then
                            n = rr(k, 1).Row
                        End If
                    Else
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(5) And rr(k, 27) = iDx(i)(5) Then
                            n = rr(k, 1).Row
                        End If
                    End If

ここのコードの意味をご教授頂けると助かります。

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

 元ネタはこちらですね？
[[20210320145513]]
 隠居じーさん　さんから詳しい説明があるまでのつなぎ。。です。
これは、多段配列または、、ジャグ配列といって
ここで配列を配列しているのですね
ReDim Preserve iDx(n)
iDx(n) = tMp

 なので↓これは
If iDx(i)(4) = "" Then
iのこれですね。。。多分。。。
tMp(4) = v(7, i - 1)    '先行機種 上位品番
（SoulMan） 2021/05/21(金) 23:32

そうですね。
全てはそこから始まっています。

（u） 2021/05/21(金) 23:54

 おはようございます。。。＾＾

 ｗ
 SoulManさん、いつも済みません。有難う御座います。m(__)m
いま、拝見致しました。
もう、すっかり、わたしの頭の中は空っぽで。これから記録探して読み返してみます。
ここ、一両日、予定が立て込んでいまして。。。←言い訳＾＾；よく精査してから←怪しい？(#^^#)
アップしますね。て、いうか、SoulManさんのご説明以外の何物でもありませんので。。。

 ＞＞これは、多段配列または、、ジャグ配列といって
 ＞＞ここで配列を配列しているのですね

 に基づいて、vba　多段配列、ジャグ配列とか検索でお調べいただくと参考サイトがたくさん御座います。

 コード全体の流れは
たしか、idxはファイル操作内容と、着色セルの行情報一覧表を作成し、着色するレンジの範囲とその配列
を用意して一覧表を基準に各処理をしていくような内容だったかと。。。
m(_ _)m
（隠居じーさん） 2021/05/22(土) 08:31

 こんばんは　＾＾
iDx(i)の項目
現機種名
行き先機種名
棚番
行き先機種 上位品番
行き先機種 投入工程
変色行
変色列

 For i = LBound(iDx) To UBound(iDx)　～　 '前機種名
の間では下記の様な事を処理しています。

 １．行き先機種名のブックが有れば
 ２．行き先機種 上位品番が空なら、棚番が同じで且つ、投入工程が同じら書込み行nを取得
 ３．行き先機種 上位品番が有れば、棚番が同じで且つ、投入工程が同じで且つ、上位品番が同じなら、書込み行nを取得
 ４．書込み対象行がゼロでなければ
 ５．現機種名が空白で無ければ、書込みブックのＡ列n行目に現機種名を書込み
 ６．変数に行き先機種名を格納
 ７．変数に書込みブックのＦ列n行目の値を格納
 ８．行き先機種名のブックが無ければエラーＭＳＧを出し終了処理

[[20210320145513]] 1
[[20210405211137]] 2

 2のほうで、もこな２　さんがかなり掘り下げたご解説を
戴いていますので、是非ご参照ください。
以下は私が解りにくいなと自分でも思う項目です。
各説明サイト、ＶＢＡ本等でご確認いただくと理解いただけるかと。。。
１．配列、[ジャグ配列]
２．範囲、に関して、全セルを対象としたセル、アドレス
　　と、任意で指定した範囲のセルアドレスの指定の相違点
３．任意の範囲を配列に格納すれば同じ数値で、各セル番地と
　　二次元配列の要素を参照する添え字は同じものを使える[同じになる]

 後書き
私のコーディングの癖といいますか、処理速度ＵＰを意識し
配列を中心にロジックを勘案致しましたが、手元に処理情報が
有れば、配列に統一して書いたかもしれませんが、一部ピンポ
イントで書込みをしたため、セル全体と任意の範囲、配列の三つ巴
となり、可読性の悪いコーディングになったかもしれません。
新規シートを追加の上、IDXのテキストダンプをとり対応一覧表を
ご作成の上、コードと突き合わせると、解りやすいかもしれません。
m(_ _)m
（隠居じーさん） 2021/05/22(土) 17:45

ご対応ありがとうございます。
処理の順番や内容まで書いて頂き助かります。
前機種の方は
配列に入ったidx(3)棚番と開いたら前機種ファイルの棚番が一致したら処理を行うという人しでよろしいでしょうか？
（u） 2021/05/22(土) 17:59

＞＞配列に入ったidx(3)棚番と開いたら前機種ファイルの棚番が一致
＞＞したら処理を行うという人しでよろしいでしょうか？

 はい。。。そのようになっているかと。。。思います。m(_ _)m
（隠居じーさん） 2021/05/22(土) 18:09

こんばんは
前機種も行き先機種と同様の処理をしようとしています。

   For i = LBound(iDx) To UBound(iDx)
     If iDx(i)(1) <> "" Then
            fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(1) & ".xlsx"
            If zWbExists(fNmTx) Then

                Set beforeB = Workbooks.Open(fNmTx)
                With beforeB.Worksheets(1)
                Set rr = .Range("B6:AJ359")
                For k = 2 To rr.Rows.Count
                    If iDx(i)(8) = "" Then
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(9) Then
                            n = rr(k, 1).Row
                        End If
                    Else
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(9) And rr(k, 27) = iDx(i)(9) Then
                            n = rr(k, 1).Row
                        End If
                    End If
                Next
                   n = Application.Match(iDx(i)(3), .Range("B:B"), 0)
                    If Not IsError(n) Then
                    If .Cells(n, "H") = "" Then .Cells(n, "H") = iDx(i)(7) '空白なら書き込む　文字があったら何もしない
                           .Cells(n, "H").EntireColumn.AutoFit
                        dAtaBk = .Cells(n, "E").Value
                        End If
                End With
                beforeB.Close True
                Set beforeB = Nothing

            Else
                MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
                Exit For
            End If
        End If
同ファイルの中にU1(1機種目)とU2(2機種目)が分かれていて、U1からU2の書き込みはうまくいきました。
しかし３機種目の別ファイルに書き込む際にU2と３機種目の共通部品の書き込みが上手くいきません。
上手くいかない場所は
前機種ファイル(U2)のH列に行き先機種名が書き込まれない
行き先ファイル(3機種目)のC列に前機種ファイルのE列の値を取得してくるはずだが、
なぜがU1でも共通部品があるのですがU1のE列の値を書き込んでいる
どこがおかしいのでしょうか？
全体のコードも掲示します。
Application.ScreenUpdating = False
    Const zProgramID  As String = "機種間共通部品,Z軸検索改良版??7.xlsm"
    Dim zTb           As Workbook
    Dim i             As Long
    Dim j             As Long
    Dim k             As Long
    Dim n             As Long
    Dim v()           As Variant
    Dim tMp()         As Variant
    Dim iDx()         As Variant
    Dim leadB         As Workbook
    Dim beforeB       As Workbook
    Dim x             As Variant
    Dim fNmTx         As String
    Dim fNmBk         As String
    Dim dAtaBk        As Variant
    Dim rr            As Range
    Dim t             As Double
    t = Timer
   Set zTb = Workbooks(zProgramID)
    With zTb.Worksheets("機種間共通部品検索")
        Set r = .Range("D1:ABW154")
        v = r.Value
    End With
     For i = 2 To UBound(v, 2) Step 15
        For j = 11 To UBound(v, 1)
           If v(j, i) <> "" And r(j, i + 2).DisplayFormat.Interior.Color = 16777215 Then
                ReDim tMp(1 To 11)
                flgcnt = flgcnt + 1
                tMp(1) = v(3, i + 1) '現ファイル名
                tMp(2) = r(j, i + 2) '行き先ファイル名
                tMp(3) = v(j, i + 3)  '棚番
                tMp(4) = v(j, i - 1)    '行き先機種 上位品番
                tMp(5) = v(j, i)      '行き先機種 投入工程
                tMp(6) = v(8, i + 1)  '現機種名
                tMp(7) = v(j, i + 1)  '行き先機種名
                tMp(8) = v(5, i + 1)  '現機種 上位品番
                tMp(9) = v(5, i + 2)  '現機種 投入工程
                tMp(10) = j
                tMp(11) = i + 2
                ReDim Preserve iDx(n)
                iDx(n) = tMp
                n = n + 1
           End If
        Next
    Next
    n = 0
    '前機種
    For i = LBound(iDx) To UBound(iDx)
     If iDx(i)(1) <> "" Then
            fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(1) & ".xlsx"
            If zWbExists(fNmTx) Then

                Set beforeB = Workbooks.Open(fNmTx)
                With beforeB.Worksheets(1)
                Set rr = .Range("B6:AJ359")
                For k = 2 To rr.Rows.Count
                    If iDx(i)(8) = "" Then
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(9) Then
                            n = rr(k, 1).Row
                        End If
                    Else
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(9) And rr(k, 27) = iDx(i)(9) Then
                            n = rr(k, 1).Row
                        End If
                    End If
                Next
                   n = Application.Match(iDx(i)(3), .Range("B:B"), 0)
                    If Not IsError(n) Then
                    If .Cells(n, "H") = "" Then .Cells(n, "H") = iDx(i)(7) '空白なら書き込む　文字があったら何もしない
                           .Cells(n, "H").EntireColumn.AutoFit
                        dAtaBk = .Cells(n, "E").Value
                        End If
                End With
                beforeB.Close True
                Set beforeB = Nothing

            Else
                MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
                Exit For
            End If
        End If
         '行き先機種名
        fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(2) & ".xlsx"
        If zWbExists(fNmTx) Then

            Set leadB = Workbooks.Open(fNmTx)
             r(iDx(i)(10), iDx(i)(11)).Interior.Color = vbYellow
            With leadB.Worksheets(1)
             Set rr = .Range("B6:AJ359")
                For k = 2 To rr.Rows.Count
                    If iDx(i)(4) = "" Then
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(5) Then
                            n = rr(k, 1).Row
                        End If
                    Else
                        If rr(k, 1) = iDx(i)(3) And rr(k, 30) = iDx(i)(5) And rr(k, 27) = iDx(i)(4) Then
                            n = rr(k, 1).Row
                        End If
                    End If
                Next
                If n > 0 Then
                    If iDx(i)(1) <> "" Then .Cells(n, "A") = iDx(i)(6)
                    .Cells(n, "A").EntireColumn.AutoFit
                     If .Cells(n, "C") = "" Then .Cells(n, "C") = dAtaBk
                    dAtaBk = ""
                End If
                n = 0
            End With
            leadB.Close True
            Set rr = Nothing
            Set leadB = Nothing

        Else

            MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
            Exit For
        End If
        If i Mod 30 = 0 Then DoEvents
    Next
    Set zTb = Nothing
    Erase v, iDx, tMp
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
    zWbExists = False
    If Dir(fp) <> "" Then zWbExists = True
End Function
Private Sub CommandButton13_Click()
Columns("C:YA").AutoFit
End Sub

（u） 2021/05/22(土) 23:56

 おはようございます　＾＾
大分、元情報も、コードも。。。ご変更のよぉ～で。。。そのぉ～
私の理解をこえているよぉ～ですので。一概には言えないのですが
せっかく条件を改めて求めた書込み行ｎを
もう一度、従来の棚番一致で求める行におきかわっているよぉ～な気が
するのですが。気のせいでしょうか。。。(#^.^#)ｖ
m(_ _)m
（隠居じーさん） 2021/05/23(日) 06:54

朝早くに申し訳ありません。
おはよう御座います。
前機種上位品番idx(8).前機種投入工程idx(9)を追加しました。
これを、前機種のコード中追加して
idx(3)の棚番と前機種上位品番idx(8)と前機種投入工程idx(9)と一致したら処理
を開始して、一致した行のh列に行先機種名を書き込み、e列の値を行き先機種の
c列に書き込む処理をしようとしました。

（u） 2021/05/23(日) 10:16

 おはようございます　＾＾

 n = Application.Match(iDx(i)(3), .Range("B:B"), 0)

      ↑　ここ。。。いらないのでは
 あと

 If Not IsError(n) Then

 ｎがゼロより大きければに変えるとか
では。どうなるでしょうか。。。＾＾；
ちょっと今から出かけます。。。頑張ってくださいね。
m(_ _)m
（隠居じーさん） 2021/05/23(日) 10:59

コメント返信：

[ 一覧(最新更新順) ]

[[20210521231309]] 『転記について』（u） ページの最後に飛ぶ

[[20210521231309]]　『転記について』（u）　ページの最後に飛ぶ