Need Help - Macro Not Working Properly

[johndoh453]

Hello. This is my first time posting in this forum. I have a spreadsheet that I am working with that is currently using three different macros. I received help on the largest of the three macros. I understand a bit about macro coding, but not enough to troubleshoot what is going wrong with the code.

In the spreadsheet attached I have columns of data. Some columns have headers and no data for them. I have a macro to remove these empty columns so that they will not be used in the data sets. I have a second macro that will then create a large table using the initial data and performing calculations. The third macro will clean up any blank rows.

It uses "Lot 1" and "Lot 2" for part of the data analysis. It performs calculations using the data sets with Lot 1 and then does the same with Lot 2. The problem that I am having is that after it reaches the end of the data sets with Lot 1, instead of going on to Lot 2, it performs duplicate analysis of the first 2 data sets using Lot 1 again, and then just picks up with Lot 2 where Lot 1 ended, neglecting to analyze the first two data sets with Lot 2.

I know that may seem confusing, but running the macros in the spreadsheet should help understand the problem. I am hoping that someone can tell me where I may have gone wrong. Thank you.

[Aussiebear]

Rather than attach the workbook why not simply post the code if you think the error occurs within the code itself?


Option Explicit

Sub AddSetToData()
Dim LastRowData As Double
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
Dim DataRows As Double
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
DataRows = Cells(1, "E").End(xlDown).Row - 2
For SetCtr = 2 To SetCnt
LastRowData = Cells(Rows.Count, "B").End(xlUp).Row + 1
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
Cells(SetCtr, "A").Copy _
Destination:=Range(Cells(LastRowData, "B"), Cells(LastRowData + (Data4Sets * 22 - 1), "B"))
For Data4Ctr = 4 To Data4Sets * 4 Step 4
LastRowData = Cells(Rows.Count, "C").End(xlUp).Row + 1
Range(Cells(2, Data4Ctr), Cells(21, Data4Ctr + 3)).Copy _
Destination:=Cells(LastRowData, "C")
Cells(1, Data4Ctr).Copy _
Destination:=Range(Cells(LastRowData, "C"), Cells(LastRowData + DataRows, "C"))
LastRowData = Cells(Rows.Count, "D").End(xlUp).Row

'Cells(LastRowData, "G").Formula = "=STDEV(F" & LastRowData - 6 & ":F" & LastRowData & ")/AVERAGE(F" & LastRowData - 6 & ":F" & LastRowData & ")"
'LastRowData = Cells(Rows.Count, "H").End(xlUp).Row + 1
'Cells(SetCtr, "B").Copy _
'Destination:=Range(Cells(LastRowData, "H"), Cells(LastRowData + DataRows, "H"))
Cells(24, "H").Formula = "=F24*$B$2*$C$2"
Cells(24, "H").Copy _
Destination:=Range(Cells(24, "H"), Cells(LastRowData + DataRows, "H"))
'Cells(LastRowData, "I").Formula = "=AVERAGE(H" & LastRowData - 6 & ":H" & LastRowData & ")"
Cells(24, "J").Formula = "=F24*H24"
Cells(24, "J").Copy _
Destination:=Range(Cells(25, "J"), Cells(LastRowData + DataRows, "J"))
'Cells(LastRowData, "K").Formula = "=INDEX($R$1:$R$10,MATCH(C" & LastRowData - 6 & ":C" & LastRowData & ",$Q$1:$Q$10,0))"
'Cells(11, "L").Formula = "=H24/(INDEX($R$1:$R$10,MATCH(C11,$Q$1:$Q$10,0)))"
'Cells(11, "L").Copy _
'Destination:=Range(Cells(11, "L"), Cells(LastRowData + DataRows, "L"))
Next Data4Ctr
Next SetCtr
End Sub

[p45cal]

Try:

Sub AddSetToData()
Dim LastRowData As Double
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
Dim DataRows As Double
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
DataRows = Cells(1, "E").End(xlDown).Row - 2
For SetCtr = 2 To SetCnt
LastRowData = Cells(Rows.Count, "B").End(xlUp).Row + 1
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
Cells(SetCtr, "A").Copy Destination:=Range(Cells(LastRowData, "B"), Cells(LastRowData + (Data4Sets * 22 - 1), "B"))

For Data4Ctr = 4 To Data4Sets * 4 Step 4
LastRowData = Cells(Rows.Count, "C").End(xlUp).Row + 1
Range(Cells(2, Data4Ctr), Cells(21, Data4Ctr + 3)).Copy Destination:=Cells(LastRowData, "C")
Cells(1, Data4Ctr).Copy Destination:=Range(Cells(LastRowData, "C"), Cells(LastRowData + DataRows, "C"))

Cells(LastRowData, "H").Formula = "=F" & LastRowData & "*$B$" & SetCtr & "*$C$" & SetCtr 'changed
Cells(LastRowData, "H").Copy Destination:=Range(Cells(LastRowData, "H"), Cells(LastRowData + DataRows, "H")) 'changed

LastRowData = Cells(Rows.Count, "D").End(xlUp).Row 'moved

Cells(24, "J").Formula = "=F24*H24"
Cells(24, "J").Copy Destination:=Range(Cells(25, "J"), Cells(LastRowData + DataRows, "J"))

'Cells(LastRowData, "G").Formula = "=STDEV(F" & LastRowData - 6 & ":F" & LastRowData & ")/AVERAGE(F" & LastRowData - 6 & ":F" & LastRowData & ")"
'LastRowData = Cells(Rows.Count, "H").End(xlUp).Row + 1
'Cells(SetCtr, "B").Copy 'Destination:=Range(Cells(LastRowData, "H"), Cells(LastRowData + DataRows, "H"))
'Cells(LastRowData, "I").Formula = "=AVERAGE(H" & LastRowData - 6 & ":H" & LastRowData & ")"
'Cells(LastRowData, "K").Formula = "=INDEX($R$1:$R$10,MATCH(C" & LastRowData - 6 & ":C" & LastRowData & ",$Q$1:$Q$10,0))"
'Cells(11, "L").Formula = "=H24/(INDEX($R$1:$R$10,MATCH(C11,$Q$1:$Q$10,0)))"
'Cells(11, "L").Copy 'Destination:=Range(Cells(11, "L"), Cells(LastRowData + DataRows, "L"))
Next Data4Ctr
Next SetCtr
End Sub
I've not tidied up at all, which it needs - and it could be a fair bit shorter.

[johndoh453]

I ran the macro and the data looks good. All of the calculations look good so far. However, after deleting out all of the extra rows/columns cells B107:B118 still say Lot 1, yet they are using the values associated with Lot 2. It seems to be a display issue.

[johndoh453]

I ran the macro and the data looks good. All of the calculations look good so far. However, after deleting out all of the extra rows/columns cells B107:B118 still say Lot 1, yet they are using the values associated with Lot 2. It seems to be a display issue.

I think I found the line of code that was causing the issue. I made a change and now the data looks better.

[p45cal]

try:
Sub AddSetToData()
'Dim LastRowData As Double
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
'Dim DataRows As Double
Dim LotFirstRow As Long, DestTopLeftCell As Range, RowCount As Long, SourceRng As Range
Dim LotLastRow As Long, ThisLotRng As Range
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
For SetCtr = 2 To SetCnt
LotFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For Data4Ctr = 4 To Data4Sets * 4 Step 4
Set DestTopLeftCell = Cells(Rows.Count, "D").End(xlUp).Offset(1, -1)
RowCount = Cells(1, Data4Ctr + 1).End(xlDown).Row - 1
Set SourceRng = Cells(2, Data4Ctr).Resize(RowCount, 4)
SourceRng.Copy DestTopLeftCell
Next Data4Ctr
LotLastRow = DestTopLeftCell.Row + RowCount - 1
Set ThisLotRng = Cells(LotFirstRow, "B").Resize(LotLastRow - LotFirstRow + 1)
ThisLotRng.Value = Cells(SetCtr, 1).Value
ThisLotRng.Offset(, 6).FormulaR1C1 = "=RC[-2]*R" & SetCtr & "C2*R" & SetCtr & "C3"
ThisLotRng.Offset(, 8).FormulaR1C1 = "=RC[-4]*RC[-2]"
Next SetCtr
End Sub

Sub DeleteColumnsThatLookEmpty()
ClearPeskyBlankCellsWhichArent
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim Rng As Range, ix As Long
Set Rng = Intersect(Range("D2:EA2"), ActiveSheet.UsedRange)
For ix = Rng.Count To 1 Step -1
If Trim(Replace(Rng.Item(ix).Text, Chr(160), Chr(32))) = "" Then
Rng.Item(ix).EntireColumn.Delete
End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Sub ClearPeskyBlankCellsWhichArent()
Dim cll As Range
For Each cll In ActiveSheet.UsedRange.Cells
If Not cll.HasFormula And Len(cll.Value) = 0 Then cll.ClearContents
Next cll
End Sub
There is a bunch of lines which you commented out to add other formulae. To add these could you upload a file with those formulae in place on the sheet and I'll code it - it should be quite easy now.

The last sub is called as part of the DeleteColumnsThatLookEmpty sub. These cells that looked blank were causing problems, and that ClearPeskyBlankCellsWhichArent needs to have been executed for my AddSetToData to work properly. You probably won't need the DeleteRowsThatLookEmpty now!

[p45cal]

Adding these 4 lines:
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "F").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "G").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "H").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "I").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
between
SourceRng.Copy DestTopLeftCell
and
Next Data4Ctr
will populate columns G and I as I think you want.
I don't know how you want to populate columns K and L.

Edit post posting: Forgot to say, you should
Dim FormulaSourceAddr As String too at the top.

[johndoh453]

There is a bunch of lines which you commented out to add other formulae. To add these could you upload a file with those formulae in place on the sheet and I'll code it - it should be quite easy now.

The last sub is called as part of the DeleteColumnsThatLookEmpty sub. These cells that looked blank were causing problems, and that ClearPeskyBlankCellsWhichArent needs to have been executed for my AddSetToData to work properly. You probably won't need the DeleteRowsThatLookEmpty now!

I put the code into the spreadsheet and ran it. Looks really good. I've also attached the file with all other formulae added to the spreadsheet. There was one error that I had made myself in the spreadsheet and it is for an equation in column H. The equation should read for cell H24: =10^((F24-C2)/B2), where cell H24 is for Lot 1 and the C2 and B2 in the equation would change to C3 and B3 when using Lot 2 data.

Also, this is just for some aesthetics, but would it be possible to add a blank row after each Set of data? If not, its not big problem. It's just something I was thinking of this morning.

Thank you for all the help you've given me so far!!

[p45cal]

Work is in progress.


Also, this is just for some aesthetics, but would it be possible to add a blank row after each Set of data? Just a nomenclature question, regarding what you mean by Set of data;
In cell B23 you have a header Set, and in column C you have a header Data with the likes of Set A, Set B etc.
What are you calling a set in this case? It will tell me how many and where I place separator blank rows.

[johndoh453]

Work is in progress.
Just a nomenclature question, regarding what you mean by Set of data;
In cell B23 you have a header Set, and in column C you have a header Data with the likes of Set A, Set B etc.
What are you calling a set in this case? It will tell me how many and where I place separator blank rows.

The way that I was thinking of having would be a space after each set. So after Set A there would be a space, after Set B there would be a space, and so on. I now see how that can be confusing when I do reference "set" and "data" in the spreadsheet.

Hope that helps.

[p45cal]

Check thoroughly the formulae - I may not have got them right:
Sub AddSetToData()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Range("B24:L500").Clear
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
Dim LotFirstRow As Long, DestTopLeftCell As Range, RowCount As Long, SourceRng As Range
Dim AllResultsFirstRow As Long, rw As Long
Dim LotLastRow As Long, ThisLotRng As Range, FormulaSourceAddr As String
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
AllResultsFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For SetCtr = 2 To SetCnt
LotFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For Data4Ctr = 4 To Data4Sets * 4 Step 4
Set DestTopLeftCell = Cells(Rows.Count, "D").End(xlUp).Offset(1, -1)
RowCount = Cells(1, Data4Ctr + 1).End(xlDown).Row - 1
Set SourceRng = Cells(2, Data4Ctr).Resize(RowCount, 4)
SourceRng.Copy DestTopLeftCell
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "F").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "G").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "H").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "I").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "J").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "K").FormulaR1C1 = "=INDEX(R24C16:R43C16,MATCH(RC[-8],R24C15:R43C15,0))"
Cells(DestTopLeftCell.Row, "L").Resize(RowCount).FormulaR1C1 = "=RC[-4]/R" & DestTopLeftCell.Row + RowCount - 1 & "C11"
Next Data4Ctr
LotLastRow = DestTopLeftCell.Row + RowCount - 1
Set ThisLotRng = Cells(LotFirstRow, "B").Resize(LotLastRow - LotFirstRow + 1)
ThisLotRng.Value = Cells(SetCtr, 1).Value
ThisLotRng.Offset(, 6).FormulaR1C1 = "=10^((RC[-2]-R" & SetCtr & "C3)/R" & SetCtr & "C2)"
Range("H24").FormulaR1C1 = "=10^((RC[-2]-R2C3)/R2C2)"
Next SetCtr
'Add blank row between sets:
For rw = LotLastRow To AllResultsFirstRow Step -1 'separator between sets in column C
If Cells(rw - 1, "G").HasFormula Then
Cells(rw, "B").Resize(, 11).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Cells(rw, "B").Resize(, 11).ClearFormats
End If
Next rw
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[johndoh453]

Check thoroughly the formulae - I may not have got them right:
Sub AddSetToData()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Range("B24:L500").Clear
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
Dim LotFirstRow As Long, DestTopLeftCell As Range, RowCount As Long, SourceRng As Range
Dim AllResultsFirstRow As Long, rw As Long
Dim LotLastRow As Long, ThisLotRng As Range, FormulaSourceAddr As String
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
AllResultsFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For SetCtr = 2 To SetCnt
LotFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For Data4Ctr = 4 To Data4Sets * 4 Step 4
Set DestTopLeftCell = Cells(Rows.Count, "D").End(xlUp).Offset(1, -1)
RowCount = Cells(1, Data4Ctr + 1).End(xlDown).Row - 1
Set SourceRng = Cells(2, Data4Ctr).Resize(RowCount, 4)
SourceRng.Copy DestTopLeftCell
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "F").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "G").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "H").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "I").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "J").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "K").FormulaR1C1 = "=INDEX(R24C16:R43C16,MATCH(RC[-8],R24C15:R43C15,0))"
Cells(DestTopLeftCell.Row, "L").Resize(RowCount).FormulaR1C1 = "=RC[-4]/R" & DestTopLeftCell.Row + RowCount - 1 & "C11"
Next Data4Ctr
LotLastRow = DestTopLeftCell.Row + RowCount - 1
Set ThisLotRng = Cells(LotFirstRow, "B").Resize(LotLastRow - LotFirstRow + 1)
ThisLotRng.Value = Cells(SetCtr, 1).Value
ThisLotRng.Offset(, 6).FormulaR1C1 = "=10^((RC[-2]-R" & SetCtr & "C3)/R" & SetCtr & "C2)"
Range("H24").FormulaR1C1 = "=10^((RC[-2]-R2C3)/R2C2)"
Next SetCtr
'Add blank row between sets:
For rw = LotLastRow To AllResultsFirstRow Step -1 'separator between sets in column C
If Cells(rw - 1, "G").HasFormula Then
Cells(rw, "B").Resize(, 11).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Cells(rw, "B").Resize(, 11).ClearFormats
End If
Next rw
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub


I ran the VBA and the table looks great. Everything is matching up.

Just a question that in the future if I ever would want to take an average of column F, what would I need to do? I tried to insert a formula into the code for column G to take an average of column F and it screwed up the display of everything. I shifted the cells over as well for all the other formulas. So I'm not sure where I went wrong, but what I tried to do was this:
Sub AddSetToData()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Range("B24:L500").Clear
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
Dim LotFirstRow As Long, DestTopLeftCell As Range, RowCount As Long, SourceRng As Range
Dim AllResultsFirstRow As Long, rw As Long
Dim LotLastRow As Long, ThisLotRng As Range, FormulaSourceAddr As String
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
AllResultsFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For SetCtr = 2 To SetCnt
LotFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For Data4Ctr = 4 To Data4Sets * 4 Step 4
Set DestTopLeftCell = Cells(Rows.Count, "D").End(xlUp).Offset(1, -1)
RowCount = Cells(1, Data4Ctr + 1).End(xlDown).Row - 1
Set SourceRng = Cells(2, Data4Ctr).Resize(RowCount, 4)
SourceRng.Copy DestTopLeftCell
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "F").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "G").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "H").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "I").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "J").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "K").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "L").FormulaR1C1 = "=INDEX(R24C16:R43C16,MATCH(RC[-8],R24C15:R43C15,0))"
Cells(DestTopLeftCell.Row, "M").Resize(RowCount).FormulaR1C1 = "=RC[-4]/R" & DestTopLeftCell.Row + RowCount - 1 & "C11"
Next Data4Ctr
LotLastRow = DestTopLeftCell.Row + RowCount - 1
Set ThisLotRng = Cells(LotFirstRow, "B").Resize(LotLastRow - LotFirstRow + 1)
ThisLotRng.Value = Cells(SetCtr, 1).Value
ThisLotRng.Offset(, 6).FormulaR1C1 = "=10^((RC[-2]-R" & SetCtr & "C3)/R" & SetCtr & "C2)"
Range("I24").FormulaR1C1 = "=10^((RC[-2]-R2C3)/R2C2)"
Next SetCtr
'Add blank row between sets:
For rw = LotLastRow To AllResultsFirstRow Step -1 'separator between sets in column C
If Cells(rw - 1, "G").HasFormula Then
Cells(rw, "B").Resize(, 11).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Cells(rw, "B").Resize(, 11).ClearFormats
End If
Next rw
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[p45cal]

First things first; there is a line in my last offering yesterday which has no busines being there at all and needs to be removed:
Range("H24").FormulaR1C1 = "=10^((RC[-2]-R2C3)/R2C2)"

Next, while I realise you're developing this code, scope creep (features requested as an afterthought) make for disproportionate amounts of extra work. :whip
Here it is, but again check it thoroughly, because I haven't. I've given it a slightly different name so that the two can co-exist.
Sub AddSetToData2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Range("B24:M500").Clear
Dim SetCnt As Double
Dim SetCtr As Double
Dim Data4Sets As Double
Dim Data4Ctr As Double
Dim LotFirstRow As Long, DestTopLeftCell As Range, RowCount As Long, SourceRng As Range
Dim AllResultsFirstRow As Long, rw As Long
Dim LotLastRow As Long, ThisLotRng As Range, FormulaSourceAddr As String
SetCnt = Cells(Rows.Count, "A").End(xlUp).Row
Data4Sets = Cells(1, "D").End(xlToRight).Column
Data4Sets = ((Data4Sets - 3) / 4)
AllResultsFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For SetCtr = 2 To SetCnt
LotFirstRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
For Data4Ctr = 4 To Data4Sets * 4 Step 4
Set DestTopLeftCell = Cells(Rows.Count, "D").End(xlUp).Offset(1, -1)
RowCount = Cells(1, Data4Ctr + 1).End(xlDown).Row - 1
Set SourceRng = Cells(2, Data4Ctr).Resize(RowCount, 4)
SourceRng.Copy DestTopLeftCell
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "F").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "G").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "H").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
FormulaSourceAddr = Cells(DestTopLeftCell.Row, "I").Resize(RowCount).Address
Cells(DestTopLeftCell.Row + RowCount - 1, "J").Formula = "=AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "K").Formula = "=STDEV(" & FormulaSourceAddr & ")/AVERAGE(" & FormulaSourceAddr & ")"
Cells(DestTopLeftCell.Row + RowCount - 1, "L").FormulaR1C1 = "=INDEX(R24C16:R43C16,MATCH(RC[-9],R24C15:R43C15,0))"
Cells(DestTopLeftCell.Row, "M").Resize(RowCount).FormulaR1C1 = "=RC[-4]/R" & DestTopLeftCell.Row + RowCount - 1 & "C12"
Next Data4Ctr
LotLastRow = DestTopLeftCell.Row + RowCount - 1
Set ThisLotRng = Cells(LotFirstRow, "B").Resize(LotLastRow - LotFirstRow + 1)
ThisLotRng.Value = Cells(SetCtr, 1).Value
ThisLotRng.Offset(, 7).FormulaR1C1 = "=10^((RC[-3]-R" & SetCtr & "C3)/R" & SetCtr & "C2)"
Next SetCtr
'Add blank row between sets:
For rw = LotLastRow To AllResultsFirstRow Step -1 'separator between sets in column C
If Cells(rw - 1, "G").HasFormula Then
Cells(rw, "B").Resize(, 12).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Cells(rw, "B").Resize(, 12).ClearFormats
End If
Next rw
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[johndoh453]

First things first; there is a line in my last offering yesterday which has no busines being there at all and needs to be removed:
Range("H24").FormulaR1C1 = "=10^((RC[-2]-R2C3)/R2C2)"

Next, while I realise you're developing this code, scope creep (features requested as an afterthought) make for disproportionate amounts of extra work. :whip


Thank you so much for all the help that you have given me. I am sorry if I began to sound like scope creep. I did not mean to in any way at all. I was just thinking ahead if future calculations may be needed. It probably just should have been a thought to myself and not passed on to you.

Either way, you have been greatly helpful.

Thanks again.

[p45cal]

to sound like scope creep. I did not mean
Scope creep (perhaps it's one word, scopecreep) isn't describing a person, but what often happens in projects; Initially, the project has a certain scope, which delimits what it does, how far it goes etc. Scopecreep is what often happens when stakeholders see the results of their project (or work in progress) and immediately get an idea they want more, or something a bit different - that is, the scope of the project begins to move around a bit.
It's not an insult!:friends: