vba - VBAネストループフロー制御

Question

私は簡潔になり、私が知っていることに固執します。このコードは、ほとんどの場合、正常に機能します。唯一の問題は、xループとzループの反復にあります。これらのループは、Yループの範囲とyLABELを設定する必要があります。私はセットを通り抜けて、物事がおかしくなった後、正しい範囲を思い付くことができます。私はそれのいくつかがzを設定するためにxから抜け出さず、次にxに戻って範囲を更新することに関係していることを知っています。

それは動作するはずですzが見つかってからx。それらの間の範囲はyに設定されます。次に、次のxですが、yは残り、yとxの間に鳴ります。xはyに設定されます。または、ループをどのように設定したかに応じて計算尺を使用します。数回繰り返した後、どこにでも行き着きます。

私はいくつかのことをしましたが、xから抜け出してzを設定するたびに、Xは範囲の一番上で再起動します。少なくともそれは私が見ていると思うものです。サンプルシートでは、オフセットがループで機能する方法を変更しましたが、考え方は同じです。この時点でgotoステートメントがあり、ループが機能した後に条件付きスイッチを見つけようとしていました。ヘルプの指示やアドバイスをいただければ幸いです。

Option Explicit

Sub parse()

            Application.DisplayAlerts = False
                'Application.EnableCancelKey = xlDisabled

            Dim strPath As String, strPathused As String
            strPath = "C:\clerk plan2"

            Dim objfso As FileSystemObject, objFolder As Folder, objfile As Object

            Set objfso = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objfso.GetFolder(strPath)

    'Loop through objWorkBooks
For Each objfile In objFolder.Files

        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Dim objWorkbook As Workbook
            Set objWorkbook = Workbooks.Open(objfile.Path)

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name
            objWorkbook.Worksheets("inbound transfer sheet").Activate
            objWorkbook.Worksheets("inbound transfer sheet").Cells.UnMerge

            'Range management WB
            Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range, lastrow As Range

            Set SRCwb = objWorkbook.Worksheets("inbound transfer sheet")
            Set SRCrange1 = SRCwb.Range("g3:g150")
            Set SRCrange2 = SRCwb.Range("a1:a150")


            Dim DSTws As Worksheet
            Set DSTws = Workbooks("clerkplan2.xlsm").Worksheets("transfer")


            Dim STR1 As String, STR2 As String, xVAL As String, zVAL As String, xSTR As String, zSTR As String

            STR1 = "INBOUND TRANS"
            STR2 = "INBOUND CA TRANS"

            Dim x As Variant, z As Variant, y As Variant, zxRANGE As Range
 For Each z In SRCrange2
        zSTR = Mid(z, 1, 16)
        If zSTR <> STR2 Then GoTo zNEXT
         If zSTR = STR2 Then
            zVAL = z
        End If

For Each x In SRCrange2
        xSTR = Mid(x, 1, 13)
        If xSTR <> STR1 Then GoTo xNEXT
         If xSTR = STR1 Then
            xVAL = x
       End If

           Dim yLABEL As String

        If xVAL = x And zVAL = z Then
         If x.Row > z.Row Then
            Set zxRANGE = SRCwb.Range(x.Offset(1, 0).Address & " : " & z.Offset(-1, 0).Address)
            yLABEL = z.Value
       Else
            Set zxRANGE = SRCwb.Range(z.Offset(-1, 0).Address & " : " & x.Offset(1, 0).Address)
            yLABEL = x.Value
         End If
       End If
                                        MsgBox zxRANGE.Address ' DEBUG
For Each y In zxRANGE


        If y.Offset(0, 6) = "Temp" Or y.Offset(0, 14) = "Begin Time" Or y.Offset(0, 15) = "End Time" Or _
            Len(y.Offset(0, 6)) = 0 Or Len(y.Offset(0, 14)) = 0 Or Len(y.Offset(0, 15)) = "0" Then yNEXT


            Set lastrow = Workbooks("clerkplan2.xlsm").Worksheets("transfer").Range("c" & DSTws.Rows.Count).End(xlUp).Offset(1, 0)
            y.Offset(0, 6).Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=True, Transpose:=False
            DSTws.Activate
            ActiveCell.Offset(0, -1) = objWorkbook.Name
            ActiveCell.Offset(0, -2) = yLABEL

            objWorkbook.Activate
            y.Offset(0, 14).Copy
            Set lastrow = Workbooks("clerkplan2.xlsm").Worksheets("transfer").Range("d" & DSTws.Rows.Count).End(xlUp).Offset(1, 0)
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=True, Transpose:=False

            objWorkbook.Activate
            y.Offset(0, 15).Copy
            Set lastrow = Workbooks("clerkplan2.xlsm").Worksheets("transfer").Range("e" & DSTws.Rows.Count).End(xlUp).Offset(1, 0)
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=True, Transpose:=False

yNEXT:
    Next y
xNEXT:
    Next x
zNEXT:
    Next z

            strPathused = "C:\clerk plan2\used\" & objWorkbook.Name


            objWorkbook.Close False
                                'Move proccesed file to new Dir

                    Dim OldFilePath As String
                    Dim NewFilePath As String

                OldFilePath = objfile 'original file location
                NewFilePath = strPathused ' new file location
                Name OldFilePath As NewFilePath ' move the file




        End If

    Next

End Sub

Answer 1

あなたが言うとき、あなたは同じ範囲をループしています：

For Each z In SRCrange2とFor Each x In SRCrange2

これは役に立ちますか、または少なくとも正しい軌道に乗ることができますか？

For Each z In SRCrange2

        zSTR = Mid(z, 1, 16)
        xSTR = Mid(x, 1, 13)

        If zSTR <> STR2 AND xSTR <> STR1 Then GoTo zNEXT

        If zSTR = STR2 Then zVAL = z
        If xSTR = STR1 Then xVAL = x

        ... [rest of code] ...

zNext:
Next z

Answer 2

ファイルをループすることは問題ではないと思うので、それについては触れません。あなたのソース データを処理済みデータに変換する場合、次のようにします。

Sub Parse()

    Dim rRng As Range
    Dim rCell As Range
    Dim bStartGroup As Boolean
    Dim shDest As Worksheet
    Dim sDateCycle As String
    Dim rNext As Range

    Set rRng = Sheet1.Range("A1:A150")
    Set shDest = ThisWorkbook.Sheets.Add

    For Each rCell In rRng.Cells
        'only change sDateCycle when a new group starts
        If StartsGroup(rCell.Value) Then
            sDateCycle = rCell.Value
        Else 'not the start of a group, so process the data
            'don't copy blanks or headers
            If IsData(rCell.Value) Then
                'find the next blank cell
                Set rNext = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Offset(1, 0)
                'write the date cycle
                rNext.Value = sDateCycle
                'write the workbook name
                rNext.Offset(0, 1).Value = rRng.Parent.Parent.Name
                'write the time in, time out, and smelly
                rCell.Offset(0, 1).Resize(1, 3).Copy rNext.Offset(0, 2).Resize(1, 3)
            End If
        End If
    Next rCell

End Sub

Function StartsGroup(ByVal sValue As String) As Boolean

    'You need to write this funciton to return True when the cell you're on starts a new date cycle
    'I wrote it to check if everything after the last space is a date
    'Your logic may be different (and easier)

    Dim lSpace As Long

    lSpace = InStrRev(sValue, Space(1))

    If lSpace > 0 Then
        StartsGroup = IsDate(Mid(sValue, lSpace + 1, Len(sValue)))
    End If

End Function

Function IsData(ByVal sValue As String) As Boolean

    'You need to write this function to return True when the cell your on should be copied
    'I wrote it to not copy blanks or headers
    'Your logic will likely be different

    IsData = Len(sValue) > 0 And sValue <> "clerks"

End Function

ファイルをループするループにこれを組み込むために、いくつかの大きな変更がありますが、いくつかのアイデアが得られるかもしれません。基本的な流れは、現在のセルがグループを開始する場合、その値を sDateCycle に保存することです。グループを開始しない場合は、有効なデータであることを確認し、有効な場合は shDest に書き込みます。

shDest を同じワークブックの新しいワークシートにしたことに注意してください。Set shDest = ... 行を変更して、書き込み先のシートを指すようにするだけです。

StartsGroup と IsData を別々の関数に入れると、作業が簡単になると思います。ただし、これらの関数に rCell.Value を渡す必要はありません。たとえば、列 G または複数の列をチェックする場合は、rCell を渡すことができます (関数パラメーターを、ByVal sValue As String ではなく ByRef rCell as Range に変更します)。次に、関数で言うことができます

StartsGroup =  rCell.Value = "This" and rCell.Offset(0,10).Value = "That"

またはあなたの論理が何であれ。これらの関数で何をする必要があるとしても、現在のセルの観点から考えれば、ループは 1 回だけで済みます。たとえば、2 行下と 1 行右のセルは、グループの開始を識別するために特定の値である必要があります。