For Each Loop looping to many times

[jwhitley]

Hello,

I' wrote the following code to copy values from one workbook and paste to another based on the previous day followed by averaging the previous day to the first day of the month. That works well with static ranges for instance a10 to previous day (a26). I have 3 nested For Each loops, one for finding the previous day in a range of days (same month), another For Each loop for the nine rows of data being copied to a workbook that houses nine equally spaced columns of cells, the third For Each loop jumps to the next block of cells. Each block of cells has a date column. My problem, the loop runs through completely once then continues. I may have the copy loop and jump to next block of cells loop in reverse order, Although i tried switching and it continues for the reverse number of counts. Below is my code, thanks in advance.
[VBA]Sub Copy_Paste_Deliveries2()
Proj_Dir = "H:\SOPUS Supply\Process Improvement Projects\"
Proj_Wb_1 = "Proj 0513 - JW Process Improvements.xlsm"
Proj_Wb = Proj_Dir & Proj_Wb_1
AllPages_Wb = "all pages.xlsm"
Workbooks.Open Proj_Wb
Dim QCell As Range
For i = 1 To 113 Step 14
For j = 2 To 9 Step 1
Set QCell = Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cells(10, i), Cells(40, i))
For Each Cell In QCell
If Cell = Date - 1 Then
Workbooks(AllPages_Wb).Worksheets("Reconsign").Cells(j, 11).Copy
Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cell.Address).Offset(0, 2).PasteSpecial Paste:=xlPasteValues
Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cell.Address).Offset(0, 2).Value = Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cell.Address).Offset(0, 2).Value
Application.CutCopyMode = False
r = Range(Cell.Offset(0, 2), Cells(10, i + 2))
Cell.Offset(1, 2) = Round(WorksheetFunction.Average(r), 0)
Cell.Offset(1, 2).AutoFill Destination:=Range(Cell.Offset(1, 2), Cells(40, i + 2)), Type:=xlFillDefault
End If
Next Cell
Next j
Next i
End Sub[/VBA]

[SamT]

[VBA]Sub Copy_Paste_Deliveries2()
Proj_Dir = "H:\SOPUS Supply\Process Improvement Projects\"
Proj_Wb_1 = "Proj 0513 - JW Process Improvements.xlsm"
Proj_Wb = Proj_Dir & Proj_Wb_1
AllPages_Wb = "all pages.xlsm"
Workbooks.Open Proj_Wb
Dim QCell As Range
For i = 1 To 113 Step 14
For j = 2 To 9 Step 1
Set QCell = Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cells(10, i), Cells(40, i))
For Each Cell In QCell
If Cell = Date - 1 Then
Workbooks(AllPages_Wb).Worksheets("Reconsign").Cells(j, 11).Copy
Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cell.Address).Offset(0, 2).PasteSpecial Paste:=xlPasteValues
Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cell.Address).Offset(0, 2).Value = Workbooks(Proj_Wb_1).Worksheets("Sheet1").Range(Cell.Address).Offset(0, 2).Value
Application.CutCopyMode = False
r = Range(Cell.Offset(0, 2), Cells(10, i + 2))
Cell.Offset(1, 2) = Round(WorksheetFunction.Average(r), 0)
Cell.Offset(1, 2).AutoFill Destination:=Range(Cell.Offset(1, 2), Cells(40, i + 2)), Type:=xlFillDefault
End If
Next Cell
Next j
Next i
End Sub[/VBA]

[SamT]

I think I have correctly rewritten the code to perform exactly as before, with the exception of adding the two Application.Calculation lines

[VBA]Sub SamT_Copy_Paste_Deliveries2()
Proj_Dir = "H:\SOPUS Supply\Process Improvement Projects\"
Proj_Wb_1 = "Proj 0513 - JW Process Improvements.xlsm"
Proj_Wb = Proj_Dir & Proj_Wb_1
AllPages_Sht = Workbooks("all pages.xlsm").Sheets("Reconsign")
Workbooks.Open Proj_Wb

Application.Calculation = xlCalculationManual

With Workbooks(Proj_Wb_1).Worksheets("Sheet1")
For Col = 1 To 113 Step 14 'Columns with Dates, used for QCell & Cell
For Rw = 2 To 9 'Used for cell to copy from.
Set QCell = .Range(Cells(10, Col), Cells(40, Col)) 'Column of Dates to compare
For Each Cell In QCell
If Cell = Date - 1 Then
AllPages_Sht.Range("K" & Rw).Copy
Cell.Offset(0, 2).PasteSpecial Paste:=xlPasteValues
'Cell.Offset(0, 2).Value = Cell.Offset(0, 2).Value
'Application.CutCopyMode = False
r = Range(Cell.Offset(0, 2), Cell.Offset(10, 2)) 'Cell.Column = Col
Cell.Offset(1, 2) = Round(WorksheetFunction.Average(r), 0) 'Places result in r, May trigger autocalc
Cell.Offset(1, 2).AutoFill Destination:=Range(Cell.Offset(1, 2), Cells.Offset(40, 2)), Type:=xlFillDefault
End If
Next Cell
Next Rw
Next Col
End With

Application.Calculation = xlCalculationAutomatic

End Sub
[/VBA]

[jwhitley]

Thanks for your help SamT. My apologies for not responding timely.
I made a few adjustments to the code and incorporated your suggestions however i'm still getting the loop issue.
The loop does not jump to the next Col after going through the data cells in a row. It actually continues looping in the same Col while copying the data from each row before going to the next Col. Updated code below (s/s attached);

[vba]
FinalRow = Worksheets("OD_Sht1").Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("OD_Sht2")
For Col = 3 To 9 Step 3 'Columns to offset from Date column, used for QCell and Cell
FinalRow_Odes = Workbooks("Prac_all pages.xlsm").Worksheets("OD_Sht1").Cells(Rows.Count, 1).End(xlUp).Row
For Rw = 2 To FinalRow_Odes 'Used for cell to copy from
Set QCell = .Range(Cells(10, 1), Cells(40, 1)) 'Columns of Dates to compare
For Each Cell In QCell
If Cell = Date - 1 Then
Worksheets("OD_Sht1").Range("c" & Rw).Copy 'Deliveries
Cell.Offset(0, Col).PasteSpecial Paste:=xlPasteValues
Worksheets("OD_Sht1").Range("d" & Rw).Copy 'Inventory
Cells(45, Col + 1).PasteSpecial Paste:=xlPasteValues
Worksheets("OD_Sht1").Range("e" & Rw).Copy 'InTransit
Cells(52, Col + 1).PasteSpecial Paste:=xlPasteValues
End If
Next Cell
Next Rw
Next Col
End With
[/vba]

[SamT]

These are your loops without all the other actions
[VBA] For 3 Offset numbers 'Paste columns
For Rw = 2 To last Row in OD_Sht1 'C&P Rows
For 30 Cells In OD_SHT2 'Dates
[/VBA]
You just need to turn the loops inside out.
[VBA]For Each Date
Copy and Paste all the Rows
For Each Column Offset [/VBA]

[jwhitley]

Hey SamT,

Changing the For statement inside out did increase the speed of the code however I'm still not achieving the correct For structure for copying cells from one row pasting the data to one column then repeating the process for the next row and next column and so on. I tired inserting Exit For at various locatinos but its not getting the results I want. In the attached I've added a worksheet reflecting the desired results. Please share your thoughts.
[vba]




FinalRow = Worksheets("OD_Sht1").Cells(Rows.Count,
1).End(xlUp).Row


With
Worksheets("OD_Sht2")
Set QCell =
.Range(Cells(10, 1), Cells(40, 1)) 'Columns of Dates to
compare

For Each Cell In
QCell

If Cell = Date - 1
Then

FinalRow_Odes = Workbooks("Prac_all
pages.xlsm").Worksheets("OD_Sht1").Cells(Rows.Count,
1).End(xlUp).Row

For Col = 3 To 9 Step 3 'Columns to offset from Date column, used for QCell and
Cell

For Rw = 1 To FinalRow_Odes 'Used for cell to copy
from

Worksheets("OD_Sht1").Range("c" & Rw + 1).Copy
'Deliveries

Cell.Offset(0, Col).PasteSpecial
Paste:=xlPasteValues

Worksheets("OD_Sht1").Range("d" & Rw + 1).Copy
'Inventory

Cells(45, Col + 1).PasteSpecial
Paste:=xlPasteValues

Worksheets("OD_Sht1").Range("e" & Rw + 1).Copy
'InTransit

Cells(52, Col + 1).PasteSpecial
Paste:=xlPasteValues

Next
Rw

Next Col

End If
Next
Cell
End With
[/vba]

[snb]

Structuring precedes coding ......
It's rather difficult to find a date in May using Date -1 on the second of June....
[vba]
Sub M_snb()
With Sheets("OD_Sht2").Columns(1)
.Find(Date - 3, , xlValues, 1).Offset(, 3).Resize(, 3) = Application.Transpose(Sheets("OD_Sht1").Cells(2, 3).Resize(3))
.Find("Avail. Inv.", , xlValues, 1).Offset(, 3).Resize(, 3) = Application.Transpose(Sheets("OD_Sht1").Cells(2, 4).Resize(3))
.Find("In Transit", , xlValues, 1).Offset(, 3).Resize(, 3) = Application.Transpose(Sheets("OD_Sht1").Cells(2, 5).Resize(3))
End With
End Sub
[/vba]

You'd better use the same columnlabels in sheet SD_Sht1 as Row labels in OD_Sht2

But if you prefer a loop (1 suffices):

[VBA]
Sub M_snb_002()
sn = Sheets("OD_Sht1").Cells(1).CurrentRegion.Offset(1).Resize(3)

For j = 1 To 3
Sheets("OD_Sht2").Columns(1).Find(Choose(j, Date - 3, "Avail. Inv.", "In Transit"), , xlValues, 1).Offset(, 3).Resize(, 3) = Application.Transpose(Application.Index(sn, 0, 2 + j))
Next
End Sub

[/VBA]

[jwhitley]

SamT,

THanks for your help.
I made a couple mods (removing the resize) to meet my needs.
I like both suggestions however I prefer the 1st.
I'll work on on adding For...Next to it.

Thanks so much,
Jeffrey

[SamT]

I think that was supposed to be to snb,

[SamT]

Even though, you've only shown 2 products, you're really trying to get the data from the Daily report sheet with all Products into the Monthly report sheet by Location/per day.

Your plan is to run the code, Filter the Daily Report for a different Location, then rerun the code again. Maybe on a different Monthly Report sheet.

The Systemic Algorithm you're using will wind up in a dead end.

You can't use User Defined (range) Names because every Location has it's own three columns with identical names.

You're using hard coded Offsets, so you will have to duplicate your code for every different location on the Daily Report Sheet.

If you ever add or remove a single product in the inventory, you'll have to restructure the every Monthly Report Sheet or book, and, rewrite damn near the entire set of code.

The Data Schema you're using makes it impossible, or at least, very difficult, to use the two main Excel Management Report tools of Pivot Tables and Charts.




ps: Add the line [VBA]Option Explicit[/VBA] as the very first line in the module, above all other code. Then fix all the problem the use of Option Explicit reveals.

Also, DO NOT use the word "Cell" or any other keyword as a variable.

[SamT]

You can speed up the loops a bit by replacing the word "Cell" with Cel and
[VBA]Dim Cel As Range
Set Cel = Find(Sheets("OD_Sht2").Range("A:A"), Format(Now - 1, "m/d/yyyy"))
[/VBA]
Then remove the loop parts
[VBA] Set QCell = .Range(Cells(10, 1), Cells(40, 1)) 'Columns of Dates to compare
For Each Cel In QCell
[/VBA]

[snb]

@SamT

I assume ? :

Set QCell = .Range(.Cells(10, 1), .Cells(40, 1))

[SamT]

When looping through the QCell range, he is just looking for one date. I tried to suggest that he set a range, Cel, to the range with that date, using Find().

I've not been 100% lately and my explanations show it.

If he first Ctrl+H to change "Cell" to Cel', the line to remove would read "
For Each Cel In QCell."

I left it to the OP to figure out which Loop ending lines to remove.

[jwhitley]

yes I meant SNB.
I'll try your suggestion SamT (if it adds speed and effecientcy that's the goal). What is OP?
THanks again for both of your assistance on my question.
Jeffrey

[snb]

If speed and effficiency are your goals it's not hard to decide which suggestion to use.....

[SamT]

@ snb,

Structuring precedes coding ......

Information precedes assistance .....

An empty mind precedes acceptance .......

[snb]

@SamT

Let's stick to VBA & Excel ....

[SamT]