Question

我会简短并坚持我所知道的。这段代码大部分都可以正常工作。唯一的问题是在x和z循环的迭代中。这些to循环应设置Y循环的范围和yLABEL。在事情变得疯狂之后，我可以通过一套并提出正确的范围。我知道其中一些与不破坏x设置z然后再回到x更新范围有关。

它应该工作z然后找到x。它们之间的范围设置为y。然后接下来的x但是y保持然后在y和y之间响铃设置为y ..所以等等，有点像下楼梯的紧身。或者是一个幻灯片规则，取决于我如何设置循环，无论是在几次迭代后我都会在整个地方结束。

我已经做了一些事情，但每次我突破x来设置z，X重新开始在范围的顶部。至少那是我认为我所看到的。在示例表中，我已经改变了偏移与循环一起工作的方式，但这个想法仍然是相同的。我有goto语句，此时我将尝试在循环工作后计算出条件开关。任何帮助方向或建议表示赞赏。

Example of worksheets

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（并将函数参数更改为ByRef rCell作为Range而不是ByVal sValue As String）。然后在函数中你可以说

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

或者你的逻辑是什么。无论您在这些功能中需要做什么，只需根据您所在的单元格来考虑它，这样您只需循环一次。例如，单元格向下两行，右向一行必须是一个特定值，以识别组的开头。

VBA嵌套循环流控制

2 个答案: