I will be brief and stick to what I know. This code for the most part works as it should. The only issue is in the iteration of the x and z loop. these to loops should set the range and yLABEL for the Y loop.
I can get through a set and come up with the correct range after that things go bonkers. I know some of it has to do with not breaking out of x to set z and then back to x update the range.
It should work z is found then x. the range between them is set for y. then next x but y stays then rang between y and x is set for y.. so on and so forth kinda like a slinky down the stairs. or a slide rule depending on how I set the loops either way I end up all over the place after a couple iterations.
I have done a few things but each time I break out of x to set z , X restarts at the top of the range. At least that's what I think I am seeing. In the example sheet i have since changed the way the way the offset works with the loop but the idea is still the same. I have goto statements at this time i was going to try figuring out conditional switches after the loops were working. Any help direction or advice is appreciated.
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
