View Full Version : Need Help - Macro Not Working Properly

johndoh453

07-15-2011, 05:57 AM

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

07-15-2011, 06:19 AM

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

07-15-2011, 08:10 AM

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

07-15-2011, 10:45 AM

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

07-15-2011, 10:48 AM

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

07-15-2011, 11:15 AM

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

07-15-2011, 12:59 PM

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

07-18-2011, 07:39 AM

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

07-18-2011, 10:36 AM

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

07-18-2011, 10:41 AM

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

07-18-2011, 11:51 AM

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

07-19-2011, 06:27 AM

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

07-19-2011, 07:50 AM

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

07-19-2011, 08:10 AM

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

07-19-2011, 08:29 AM

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:

Powered by vBulletin® Version 4.2.5 Copyright © 2020 vBulletin Solutions Inc. All rights reserved.