0

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

它应该工作 z 找到然后 x。它们之间的范围设置为 y。然后下一个 x 但 y 停留然后在 y 和 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
4

2 回答 2

0

当您说：

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
于 2012-07-09T21:13:09.363 回答
0

我认为遍历文件不是问题，所以我不打算解决这个问题。如果我要获取您的源数据并将其转换为您的处理数据，我会这样做

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 as Range 而不是 ByVal sValue As String）。然后在函数中你可以说

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

或者你的逻辑是什么。无论您需要在这些函数中做什么，只需根据您所在的单元格来考虑它，因此您只需循环一次。例如，可能向下两行和向右一列的单元格必须是某个值才能识别组的开始。

于 2012-07-10T16:37:44.867 回答