VBA 중첩 루프 흐름 제어

Question

간략하게 설명하고 내가 알고있는 것에 충실합니다. 이 코드는 대부분 제대로 작동합니다. 유일한 문제는 x와 z 루프의 반복입니다. 이 to 루프는 범위를 설정하고 Y 루프에 대해 yLABEL을 설정해야합니다. 세트를 통과해서 올바른 거리를 찾아 낼 수 있습니다. 나는 그 중 일부는 x를 벗어나서 z를 설정하지 않은 다음 x를 다시 업데이트하여 범위를 업데이트하는 것과 관련이 있다는 것을 알고 있습니다.

작동해야합니다. z는 다음 x입니다. 그들 사이의 범위는 y로 설정됩니다. 그렇다면 다음 x는 있지만 y는 y 사이에 울리고 y는 x로 설정됩니다. 그래서 등등은 계단을 내려 앉은 것처럼 보입니다. 또는 슬라이드 규칙을 설정하는 방법에 따라 슬라이드를 반복하면 몇 번 반복하면 어느 곳에서나 끝납니다.

몇 가지 작업을 수행했지만 x를 설정하여 z를 설정하면 X가 범위의 맨 위에서 다시 시작됩니다. 적어도 그것은 제가 생각하는 것입니다. 예제 시트에서 나는 오프셋이 루프와 함께 작동하는 방식을 변경했으나 아이디어는 여전히 동일합니다. 나는 루프가 작동 한 후에 조건부 스위치를 알아 내려고 노력했다. 도움이되는 방향이나 조언을 주시면 감사하겠습니다.

For Each z In SRCrange2 및 For Each x In SRCrange2

이 도움을합니까, 또는 적어도 당신이 올바른 궤도에 얻을 :

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 

     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 대신 Range로 ByRef rCell로 함수 매개 변수를 변경). 그런 다음 함수에서

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

또는 논리가 무엇이든간에 말할 수 있습니다. 당신이 그 기능들에서해야 할 일이 무엇이든간에, 당신이있는 셀의 관점에서 생각하면됩니다. 그래서 한번 반복하면됩니다. 예를 들어, 셀의 두 행 아래쪽과 오른쪽 셀의 값은 그룹의 시작을 식별하는 특정 값이어야합니다.