Elegant way of shortening this code using a loops - excel

In need of some help. I am copying data from a table to specific places in another and transposing it. I know there is a faster way of doing this with a loop but for the life of me i cant figure it out.
If you look at the code the only thing changing is the column number of "Daily Dotcom" (3,4,5 then 7,8,9 then 11,12,13 etc) and the Row number of "dotFigures" (2,3,4 then 7,8,9 then 12,13,14 etc)
After thats been done, I need to do exactly the same but with 2 other tables called "dailySeasonal" and "dailyManual" using arrays called "seaFigures" and "manFigures"
So you can see why im so desperate to shorten the code, as it will get ridiculously long winded.
For i = 1 To ActiveSheet.ListObjects("dailyDotcom").ListRows.Count
If ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 1).Value = wkComm Then
'planned FTAM
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 3).Value = dotFigures(2, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 3).Value = dotFigures(2, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 3).Value = dotFigures(2, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 3).Value = dotFigures(2, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 3).Value = dotFigures(2, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 3).Value = dotFigures(2, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 3).Value = dotFigures(2, 8)
'attended FTAM
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 4).Value = dotFigures(3, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 4).Value = dotFigures(3, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 4).Value = dotFigures(3, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 4).Value = dotFigures(3, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 4).Value = dotFigures(3, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 4).Value = dotFigures(3, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 4).Value = dotFigures(3, 8)
'absence FTAM
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 5).Value = dotFigures(4, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 5).Value = dotFigures(4, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 5).Value = dotFigures(4, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 5).Value = dotFigures(4, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 5).Value = dotFigures(4, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 5).Value = dotFigures(4, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 5).Value = dotFigures(4, 8)
'planned FTPM
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 7).Value = dotFigures(7, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 7).Value = dotFigures(7, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 7).Value = dotFigures(7, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 7).Value = dotFigures(7, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 7).Value = dotFigures(7, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 7).Value = dotFigures(7, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 7).Value = dotFigures(7, 8)
'attended FTPM
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 8).Value = dotFigures(8, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 8).Value = dotFigures(8, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 8).Value = dotFigures(8, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 8).Value = dotFigures(8, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 8).Value = dotFigures(8, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 8).Value = dotFigures(8, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 8).Value = dotFigures(8, 8)
'absence FTPM
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 9).Value = dotFigures(9, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 9).Value = dotFigures(9, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 9).Value = dotFigures(9, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 9).Value = dotFigures(9, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 9).Value = dotFigures(9, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 9).Value = dotFigures(9, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 9).Value = dotFigures(9, 8)
'planned Nights
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 11).Value = dotFigures(12, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 11).Value = dotFigures(12, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 11).Value = dotFigures(12, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 11).Value = dotFigures(12, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 11).Value = dotFigures(12, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 11).Value = dotFigures(12, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 11).Value = dotFigures(12, 8)
'attended Nights
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 12).Value = dotFigures(13, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 12).Value = dotFigures(13, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 12).Value = dotFigures(13, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 12).Value = dotFigures(13, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 12).Value = dotFigures(13, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 12).Value = dotFigures(13, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 12).Value = dotFigures(13, 8)
'absence Nights
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i, 13).Value = dotFigures(14, 2)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 1, 13).Value = dotFigures(14, 3)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 2, 13).Value = dotFigures(14, 4)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 3, 13).Value = dotFigures(14, 5)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 4, 13).Value = dotFigures(14, 6)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 5, 13).Value = dotFigures(14, 7)
ActiveSheet.ListObjects("dailyDotcom").DataBodyRange(i + 6, 13).Value = dotFigures(14, 8)
End If
Next i
Any help would be much appreciated!


Use a With statement to shorten these long lines.
Use Option Explicit and declare all your variables.
Use a second loop j to count the other steps from 0 to 6
So you end up with:
Option Explicit
Public Sub DoMyStuff()
With ActiveSheet.ListObjects("dailyDotcom")
Dim i As Long, j As Long
For i = 1 To .ListRows.Count
If .DataBodyRange(i, 1).Value = wkComm Then
For j = 0 To 6
.DataBodyRange(i + j, 3).Value = dotFigures(2, 2 + j) 'planned FTAM
.DataBodyRange(i + j, 4).Value = dotFigures(3, 2 + j) 'attended FTAM
.DataBodyRange(i + j, 5).Value = dotFigures(4, 2 + j) 'absence FTAM
.DataBodyRange(i + j, 7).Value = dotFigures(7, 2 + j) 'planned FTPM
.DataBodyRange(i + j, 8).Value = dotFigures(8, 2 + j) 'attended FTPM
.DataBodyRange(i + j, 9).Value = dotFigures(9, 2 + j) 'absence FTPM
.DataBodyRange(i + j, 11).Value = dotFigures(12, 2 + j) 'planned Nights
.DataBodyRange(i + j, 12).Value = dotFigures(13, 2 + j) 'attended Nights
.DataBodyRange(i + j, 13).Value = dotFigures(14, 2 + j) 'absence Nights
Next j
End If
Next i
End With
End Sub

Related

How can I truncate these code blocks into one nested for loop?

I have 4 code blocks that take values from a row and do offsets +1, +2, +3, +4 and multiply the values under those cells (span 3 columns).
The code takes values I list in Sheet 2 and updates based off the rIterator variable (unique keys that show only what I need to update).
After I get the initial values in, I have to do the offset multiplication. How could I truncate this:
wsA.Cells(fndRow, 3).Value = rIterator.Offset(, 2).Value
wsA.Cells(fndRow, 4).Value = rIterator.Offset(, 3).Value
wsA.Cells(fndRow, 5).Value = rIterator.Offset(, 4).Value
wsA.Cells(fndRow + 1, 3).Value = rIterator.Offset(, 2).Value * 1.1
wsA.Cells(fndRow + 1, 4).Value = rIterator.Offset(, 3).Value * 1.1
wsA.Cells(fndRow + 1, 5).Value = rIterator.Offset(, 4).Value * 1.1
wsA.Cells(fndRow + 2, 3).Value = rIterator.Offset(, 2).Value * 1.15
wsA.Cells(fndRow + 2, 4).Value = rIterator.Offset(, 3).Value * 1.15
wsA.Cells(fndRow + 2, 5).Value = rIterator.Offset(, 4).Value * 1.15
wsA.Cells(fndRow + 3, 3).Value = rIterator.Offset(, 2).Value * 1.2
wsA.Cells(fndRow + 3, 4).Value = rIterator.Offset(, 3).Value * 1.2
wsA.Cells(fndRow + 3, 5).Value = rIterator.Offset(, 4).Value * 1.2
wsA.Cells(fndRow + 4, 3).Value = rIterator.Offset(, 2).Value * 1.3
wsA.Cells(fndRow + 4, 4).Value = rIterator.Offset(, 3).Value * 1.3
wsA.Cells(fndRow + 4, 5).Value = rIterator.Offset(, 4).Value * 1.3
into something like :
For i = 0 To 4
For j = 3 To 5
wsA.Cells(fndRow + i, j).Value = rIterator.Offset(, j - 1).Value
Next j
Next i
and just implement some kind of Case statement to take care of the 1.1 1.15 1.2 1.3 multipliers from the original value before the offsets?
Can provide rest of code if needed
EDIT: Ideally, I'd like it to look something kinda like this
For i = 0 To 4
For j = 3 To 5
Select Case i
Case 0
j = 1
Case 1
j = 1.1
Case 2
j = 1.15
Case 3
j = 1.2
Case 4
j = 1.3
End Select
wsA.Cells(fndRow, 3 + i).Value = rIterator.Offset(, 2).Value * j
Next j
Next i
but it's not 100% there

Put the values in an array:
Dim multplr as Variant
multplr = array(1,1.1,1.15,1.2,1.3)
Then at the end call that based on i
wsA.Cells(fndRow + i, j).Value = rIterator.Offset(, j - 1).Value * multplr(i)

I think this code should do the trick:
Dim multiplier(0 To 4) As Double
multiplier(0) = 1
multiplier(1) = 1.1
multiplier(2) = 1.15
multiplier(3) = 1.2
multiplier(4) = 1.3
For i = 0 To 4
For j = 3 To 5
wsA.Cells(fndRow + i, j).Value = rIterator.Offset(, j - 1).Value * multiplier(i)
Next j
Next i

VBA - assinging values through for loop

Is there a more efficient way of handling the below?
Range("approvedSales").Cells(raS, 2).Value = Sheet1.Cells(i, 1).Value
Range("approvedSales").Cells(raS, 3).Value = Sheet1.Cells(i, 4).Value
Range("approvedSales").Cells(raS, 4).Value = Sheet1.Cells(i, 6).Value
Range("approvedSales").Cells(raS, 5).Value = Sheet1.Cells(i, 7).Value
Range("approvedSales").Cells(raS, 6).Value = Sheet1.Cells(i, 9).Value
Range("approvedSales").Cells(raS, 7).Value = Sheet1.Cells(i, 26).Value
Range("approvedSales").Cells(raS, 8).Value = Sheet1.Cells(i, 27).Value
Range("approvedSales").Cells(raS, 9).Value = Sheet1.Cells(i, 16).Value
Range("approvedSales").Cells(raS, 10).Value = Sheet1.Cells(i, 17).Value
Range("approvedSales").Cells(raS, 11).Value = Sheet1.Cells(i, 18).Value
Range("approvedSales").Cells(raS, 12).Value = Sheet1.Cells(i, 19).Value
raS = raS + 1

The "cleaner" way to do this is to store your values in Arrays instead:
Dim array1() As Variant, array2() As Variant, i As Integer
array1 = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
array2 = Array(1, 4, 6, 7, 9, 26, 27, 16, 17, 18, 19)
For i = 0 To 10
Range("approvedSales").Cells(raS, array1(i)).Value = Sheet1.Cells(i, array2(i)).Value
Next i

dynamic with loop for i to n, adds rows but does not cover full range

I have a macro, that start from i, and ends at n. n is the end of the dynamic range. The macro adds rows and enters data based on various criterias. The code works very fine, but it only covers 85% of the total range before 'n' ends.
see code below:
Sub AddExtrasFerry()
Dim i As Long
Dim n As Long
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Original").Select
For i = 10 To n
If Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value = 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
ElseIf Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value > 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
Cells(i + 2, 16).EntireRow.Insert
Cells(i + 2, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 2, 6).Value = Cells(i, 16).Value - 100
Cells(i + 2, 1).Value = 20305
Cells(i + 2, 11).Value = ""
Cells(i + 2, 12).Value = ""
Cells(i + 2, 15).Value = ""
Cells(i + 2, 16).Value = ""
i = i + 1
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
ElseIf Cells(i, 16).Value <> "" Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = Cells(i, 16).Value
Cells(i + 1, 1).Value = 20305
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
i = i + 1
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
End If
Next i
End Sub

If you add or delete rows you need to loop backwards or you'll mess up your indexing, try this:
Sub AddExtrasFerry()
Dim i As Long
Dim n As Long
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Original").Select
For i = n To 10 step - 1
If Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value = 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
ElseIf Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value > 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
Cells(i + 2, 16).EntireRow.Insert
Cells(i + 2, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 2, 6).Value = Cells(i, 16).Value - 100
Cells(i + 2, 1).Value = 20305
Cells(i + 2, 11).Value = ""
Cells(i + 2, 12).Value = ""
Cells(i + 2, 15).Value = ""
Cells(i + 2, 16).Value = ""
ElseIf Cells(i, 16).Value <> "" Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = Cells(i, 16).Value
Cells(i + 1, 1).Value = 20305
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
End If
Next i
End Sub

Formatting text to bold and inserting formula to get sum

Above is what the code below does.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
With ws
For i = 1 To 200
If Left(.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = .Range(.Cells(i + 1, 1), .Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = 200
.Cells(i, 10).Value = Len(Cells((i + 2), 1).Value) - Len(Replace(Cells((i + 2), 1).Value, ",", "")) + 1
.Cells(i, 11).Value = "SET"
.Cells(i, 12).Resize(k - i).Value = .Cells(i, 1).Resize(k - i).Value
.Cells((i + 1), 12).Resize(k - i).Value = .Cells((i + 1), 1).Resize(k - i).Value
.Cells((i + 2), 12).Resize(k - i).Value = ws.Cells((i + 2), 1).Resize(k - i).Value
.Cells((i + 3), 12).Resize(k - i).Value = ""
.Cells((i + 4), 12).Resize(k - i).Value = "QTY"
.Cells((i + 4), 13).Resize(k - i).Value = "TYPE"
.Cells((i + 4), 15).Resize(k - i).Value = "LENGTH"
.Cells((i + 4), 16).Resize(k - i).Value = "FINISH"
.Cells((i + 4), 19).Resize(k - i).Value = "LIST"
.Cells((i + 4), 20).Resize(k - i).Value = "NET"
.Cells((i + 4), 21).Resize(k - i).Value = "MFG"
.Cells((i + 4), 22).Resize(k - i).Value = "MODEL"
.Cells((i + 5), 12).Resize(k - i).Value = .Cells((i + 3), 1).Resize(k - i).Value
.Cells((i + 5), 13).Resize(k - i).Value = .Cells((i + 3), 2).Resize(k - i).Value
.Cells((i + 5), 15).Resize(k - i).Value = .Cells((i + 3), 5).Resize(k - i).Value
.Cells((i + 5), 16).Resize(k - i).Value = .Cells((i + 3), 6).Resize(k - i).Value
.Cells((i + 5), 19).Resize(k - i).Value = .Cells((i + 3), 7).Resize(k - i).Value
.Cells((i + 5), 20).Resize(k - i).Value = .Cells((i + 3), 8).Resize(k - i).Value
.Cells((i + 5), 21).Resize(k - i).Value = .Cells((i + 3), 3).Resize(k - i).Value
.Cells((i + 5), 22).Resize(k - i).Value = .Cells((i + 3), 4).Resize(k - i).Value
i = k + 1
End If
Next i
End With
End Sub
A couple problems. First I'm not sure why but for the second data output it is missing the # of doors, SET, and all the different hardware. It looks like it is skipping it?
Second problem is i do not know how to make my headings (QTY, TYPE, LENGTH, FINISH, LIST, NET, MFG, MODEL) bold using VBA code. I think i would use text.bold but i don't think i know how to word it correctly.I would also like to put a double line underneath them including column N but excluding Q and R.
Third I would like to sum my NET prices at the end of the NET column, but im not sure how to specify that cell. I would also like the cell to the right of it to divide the sum of the net by a specific cell.
Forth, I tried doing this,
"DOOR: " & ws.Cells((i + 2), 1).Resize(k - i).Value
This triggers an error because one is a string and the other is an integer. I thought i could use CStr(), but that does not work.
When all is coded correctly i would like it to look like this.
Thanks in advance for any help!

I would move all the title row into an Array. Then you can just resize the area and assign the array.
As to your problems:
1) Math, when adding rows and refering to data that does not add the rows also there is a lot of math. You were basically overwriting data as you went.
2) one way to format the bold is Range.Font.Bold = True. With that the borders are similar Range.Borders(XlEdgeBottom).LineStyle = xlDouble.
3) Again Lots and Lots of math, Sometimes it is trial and error to get it correct.
4) You can't do that with a resize, it does not like it
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
Dim ofst As Long
Dim ttlArr() As String
ttarr = Array("QTY", "TYPE", vbNullString, "LENGTH", "FINISH", vbNullString, vbNullString, "LIST", "NET", "MFG", "MODEL")
ofst = 0
With ws
For i = 1 To 200
If Left(.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = .Range(.Cells(i + 1, 1), .Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = .Cells(i, 1).End(xlDown).Row + 2
.Cells(i + ofst, 11).Value = "SET"
.Cells(i + ofst, 12).Resize(2).Value = .Cells(i, 1).Resize(2).Value
If IsNumeric(.Cells((i + 2), 1).Value) Then
.Cells(i + ofst, 10).Value = Len("'" & Format(.Cells(i + 2, 1).Value, "#,##0")) - Len(Replace("'" & Format(.Cells(i + 2, 1).Value, "#,##0"), ",", "")) + 1
.Cells(i + ofst + 2, 12).Value = "Doors: " & Format(.Cells(i + 2, 1).Value, "#,##0")
Else
.Cells(i + ofst, 10).Value = Len(.Cells(i + 2, 1).Value) - Len(Replace(.Cells(i + 2, 1).Value, ",", "")) + 1
.Cells(i + ofst + 2, 12).Value = "Doors: " & .Cells(i + 2, 1).Value
End If
.Cells(i + ofst + 4, 12).Resize(, UBound(ttarr) + 1).Value = ttarr
.Cells(i + ofst + 4, 12).Resize(, UBound(ttarr) + 1).Font.Bold = True
.Cells(i + ofst + 4, 12).Resize(, 5).Borders(xlEdgeBottom).LineStyle = xlDouble
.Cells(i + ofst + 4, 19).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlDouble
ofst = ofst + 2
.Cells(i + ofst + 3, 12).Resize(k - i - 3).Value = .Cells(i + 3, 1).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 13).Resize(k - i - 3).Value = .Cells(i + 3, 2).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 15).Resize(k - i - 3).Value = .Cells(i + 3, 5).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 16).Resize(k - i - 3).Value = .Cells(i + 3, 6).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 19).Resize(k - i - 3).Value = .Cells(i + 3, 7).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 20).Resize(k - i - 3).Value = .Cells(i + 3, 8).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 21).Resize(k - i - 3).Value = .Cells(i + 3, 3).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 22).Resize(k - i - 3).Value = .Cells(i + 3, 4).Resize(k - i - 3).Value
.Cells(i + ofst + k - i - 1, 20).Value = WorksheetFunction.Sum(.Cells(i + ofst + 3, 20).Resize(k - i - 4))
' Change the Range("H1") to your cell with the factor
.Cells(i + ofst + k - i - 1, 21).Value = .Cells(i + ofst + k - i - 1, 20).Value / .Range("H1")
.Cells(i + ofst - 2, 17).Value = .Cells(i + ofst + k - i - 1, 21).Value
.Cells(i + ofst - 2, 18).Value = .Cells(i + ofst + k - i - 1, 21).Value * .Cells(i + ofst - 2, 10).Value
i = k - 1
End If
Next i
End With
End Sub

I believe the problem with lost data had to do with finding the last occurrence of HW* when there was no terminating HW* to locate the end-of-record. Without seeing one or two HW records as a sample, this is the best I could figure out.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long, k As Long, hw As Long, MX As Long
Set ws = ActiveSheet
With ws
MX = 200 'maybe MX = .cells(rows.count, 1).end(xlup).row
i = .Columns(1).Find(what:="HW*", after:=.Cells(MX, 1), lookat:=xlWhole).Row
k = .Columns(1).FindNext(after:=.Cells(i, 1)).Row
For hw = 1 To Application.CountIf(.Columns(1), "HW*")
If k <= i Then k = MX
Debug.Print i & ":" & k
.Cells(i, 10) = UBound(Split(.Cells(i + 2, 1).Value, Chr(44))) + 1
.Cells(i, 11).Value = "SET"
.Cells(i, 12).Resize(k - i).Value = .Cells(i, 1).Resize(k - i).Value
With .Cells(i + 4, 12)
.Resize(1, 11) = Array("QTY", "TYPE", vbNullString, _
"LENGTH", "FINISH", vbNullString, vbNullString, _
"LIST", "NET", "MFG", "MODEL")
With Union(.Cells(1, 1).Resize(1, 5), .Cells(1, 1).Resize(1, 5))
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
End With
End With
.Cells((i + 5), 12).Resize(k - i).Value = .Cells((i + 3), 1).Resize(k - i).Value
.Cells((i + 5), 13).Resize(k - i).Value = .Cells((i + 3), 2).Resize(k - i).Value
.Cells((i + 5), 15).Resize(k - i).Value = .Cells((i + 3), 5).Resize(k - i).Value
.Cells((i + 5), 16).Resize(k - i).Value = .Cells((i + 3), 6).Resize(k - i).Value
.Cells((i + 5), 19).Resize(k - i).Value = .Cells((i + 3), 7).Resize(k - i).Value
.Cells((i + 5), 20).Resize(k - i).Value = .Cells((i + 3), 8).Resize(k - i).Value
.Cells((i + 5), 21).Resize(k - i).Value = .Cells((i + 3), 3).Resize(k - i).Value
.Cells((i + 5), 22).Resize(k - i).Value = .Cells((i + 3), 4).Resize(k - i).Value
i = .Columns(1).FindNext(after:=.Cells(k - 1, 1)).Row
k = .Columns(1).FindNext(after:=.Cells(i, 1)).Row
Next hw
End With
End Sub

Dim ws As Worksheet
Dim MyWSTarget As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
Set MyWSTarget = Workbooks.Open("C:\MASTER_QT.xlsx").Sheets(1)
Dim ofst As Long
Dim ttlArr() As String
ttarr = Array("QTY", "TYPE", vbNullString, "LENGTH", "FINISH", vbNullString, vbNullString, "LIST", "NET", "MFG", "MODEL")
ofst = 17
With ws
For i = 1 To 200
If Left(ws.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = ws.Range(ws.Cells(i + 1, 1), ws.Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = ws.Cells(i, 1).End(xlDown).Row + 2
MyWSTarget.Cells(i + ofst, 3).Value = "SET"
MyWSTarget.Cells(i + ofst, 4).Resize(2).Value = ws.Cells(i, 1).Resize(2).Value
If IsNumeric(MyWSTarget.Cells((i + 2), 1).Value) Then
MyWSTarget.Cells(i + ofst, 2).Value = Len("'" & Format(ws.Cells(i + 2, 1).Value, "#,##0")) - Len(Replace("'" & Format(ws.Cells(i + 2, 1).Value, "#,##0"), ",", "")) + 1
MyWSTarget.Cells(i + ofst + 2, 4).Value = "Doors: " & Format(ws.Cells(i + 2, 1).Value, "#,##0")
Else
MyWSTarget.Cells(i + ofst + 2, 4).Value = "Doors: " & ws.Cells(i + 2, 1).Value
End If
MyWSTarget.Cells(i + ofst + 4, 3).Resize(, UBound(ttarr) + 1).Value = ttarr
MyWSTarget.Cells(i + ofst + 4, 3).Resize(, UBound(ttarr) + 1).Font.Bold = True
MyWSTarget.Cells(i + ofst + 4, 3).Resize(, 5).Borders(xlEdgeBottom).LineStyle = xlDouble
MyWSTarget.Cells(i + ofst + 4, 10).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlDouble
ofst = ofst + 2
MyWSTarget.Cells(i + ofst + 3, 3).Resize(k - i - 3).Value = ws.Cells(i + 3, 1).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 4).Resize(k - i - 3).Value = ws.Cells(i + 3, 2).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 6).Resize(k - i - 3).Value = ws.Cells(i + 3, 5).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 7).Resize(k - i - 3).Value = ws.Cells(i + 3, 6).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 10).Resize(k - i - 3).Value = ws.Cells(i + 3, 7).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 11).Resize(k - i - 3).Value = ws.Cells(i + 3, 8).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 12).Resize(k - i - 3).Value = ws.Cells(i + 3, 3).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 13).Resize(k - i - 3).Value = ws.Cells(i + 3, 4).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + k - i - 1, 11).Value = WorksheetFunction.Sum(MyWSTarget.Cells(i + ofst + 3, 11).Resize(k - i - 4))
' Change the Range("H1") to your cell with the factor
MyWSTarget.Cells(i + ofst + k - i - 1, 12).Value = MyWSTarget.Cells(i + ofst + k - i - 1, 11).Value / MyWSTarget.Range("L12")
MyWSTarget.Cells(i + ofst - 2, 8).Value = MyWSTarget.Cells(i + ofst + k - i - 1, 12).Value
MyWSTarget.Cells(i + ofst - 2, 9).Value = MyWSTarget.Cells(i + ofst + k - i - 1, 12).Value * MyWSTarget.Cells(i + ofst - 2, 2).Value
i = k - 1
End If
Next i
End With
End Sub

Making a macro execute automatically on any changes to cell value

I have prepared a big spreadsheet and I want that if any of the inputs for the spreadsheet are changed by the user, the module runs automatically to update the sheet.
Sub Biomass()
Cells(5, 4).Value = Cells(10, 17).Value
Cells(4, 1).Value = 0
Cells(5, 1).Value = 1
Cells(4, 6).Value = Cells(1, 17).Value * 50000
Cells(5, 8).Value = Cells(5, 17).Value * 12
Dim c As Long
c = Cells(1, 10).Value * Cells(4, 6).Value
cntr = 0
For i = 6 To (Cells(1, 7).Value + 4)
Cells(i, 4).Value = Cells(i - 1, 4).Value * (1 + Cells(11, 17).Value)
Cells(i, 1).Value = i - 4
Cells(i - 1, 6).Value = Cells(4, 6).Value - ((i - 5) * c)
Cells(i, 6).Value = Cells(4, 6).Value - ((i - 4) * c)
Cells(i - 1, 7).Value = Cells(i - 1, 6).Value / (1 + Cells(1, 2).Value) ^ (i - 5)
Cells(i, 7).Value = Cells(i, 6).Value / (1 + Cells(1, 2).Value) ^ (i - 4)
Cells(i - 1, 5).Value = (Cells(i - 1, 4).Value / (1 + Cells(1, 2).Value) ^ (i - 5)) + Cells(i - 2, 5)
Cells(i, 5).Value = (Cells(i, 4).Value / (1 + Cells(1, 2).Value) ^ (i - 4)) + Cells(i - 1, 5)
Cells(i, 8).Value = Cells(i - 1, 8).Value * (1 - Cells(13, 17).Value)
Cells(i - 1, 9).Value = Cells(i - 1, 8).Value / ((1 + Cells(1, 2).Value) ^ (i - 5))
Cells(i, 9).Value = Cells(i, 8).Value / ((1 + Cells(1, 2).Value) ^ (i - 4))
Cells(5, 10).Value = Cells(5, 9).Value
Cells(i, 10).Value = Cells(i - 1, 10).Value + Cells(i, 9).Value
Cells(i - 1, 11).Value = Cells(14, 17).Value / (1 + Cells(1, 2).Value) ^ (i - 5)
Cells(i, 11).Value = Cells(14, 17).Value / (1 + Cells(1, 2).Value) ^ (i - 4)
Cells(4, 12).Value = 0
Cells(i - 1, 12) = Cells(i - 2, 12).Value + Cells(i - 1, 11).Value
Cells(i, 12).Value = Cells(i - 1, 12).Value + Cells(i, 11).Value
Cells(i - 1, 13).Value = (Cells(2, 17).Value + Cells(i - 1, 5).Value - Cells(i - 1, 12).Value - Cells(i - 1, 7).Value) / Cells(i - 1, 10).Value
Cells(i, 13).Value = (Cells(2, 17).Value + Cells(i, 5).Value - Cells(i, 12).Value - Cells(i, 7).Value) / Cells(i, 10).Value
cntr = cntr + 1
If cntr = 24 Then Exit For
Next i
For g = 5 To (Cells(35, 17).Value + 4)
Cells(g, 3).Value = Cells(36, 17).Value
Next g
cntr2 = 0
For d = 5 To (Cells(1, 7).Value + 4)
Cells(d, 2).Value = Cells(21, 17).Value * Cells(d, 8).Value + Cells(d, 3).Value - Cells(d, 4).Value
cntr2 = cntr2 + 1
If cntr2 = 25 Then Exit For
Next d
cntr3 = 0
For i = (cntr + 7) To (Cells(1, 7).Value + 4)
Cells(30, 6).Value = Cells(4, 6).Value * (1 + Cells(1, 4).Value) ^ 30
c2 = Cells(1, 10).Value * Cells(30, 6).Value
Cells(30, 4).Value = Cells(5, 4).Value
Cells(i, 4).Value = Cells(i - 1, 4).Value * (1 + Cells(11, 17).Value)
Cells(i, 1).Value = i - 4
Cells(i, 6).Value = Cells(30, 6).Value - ((i - 30) * c2)
Cells(i - 1, 7).Value = Cells(i - 1, 6).Value / (1 + Cells(1, 2).Value) ^ (i - 5)
Cells(i, 7).Value = Cells(i, 6).Value / (1 + Cells(1, 2).Value) ^ (i - 4)
Cells(i - 1, 5).Value = (Cells(i - 1, 4).Value / (1 + Cells(1, 2).Value) ^ (i - 5)) + Cells(i - 2, 5)
Cells(i, 5).Value = (Cells(i, 4).Value / (1 + Cells(1, 2).Value) ^ (i - 4)) + Cells(i - 1, 5)
Cells(30, 8).Value = Cells(5, 8).Value
Cells(i, 8).Value = Cells(i - 1, 8).Value * (1 - Cells(13, 17).Value)
Cells(i - 1, 9).Value = Cells(i - 1, 8).Value / ((1 + Cells(1, 2).Value) ^ (i - 5))
Cells(i, 9).Value = Cells(i, 8).Value / ((1 + Cells(1, 2).Value) ^ (i - 4))
Cells(30, 10).Value = Cells(30, 9).Value + Cells(29, 10).Value
Cells(i, 10).Value = Cells(i - 1, 10).Value + Cells(i, 9).Value
Cells(i - 1, 11).Value = Cells(14, 17).Value / (1 + Cells(1, 2).Value) ^ (i - 5)
Cells(i, 11).Value = Cells(14, 17).Value / (1 + Cells(1, 2).Value) ^ (i - 4)
Cells(i - 1, 12) = Cells(i - 2, 12).Value + Cells(i - 1, 11).Value
Cells(i, 12).Value = Cells(i - 1, 12).Value + Cells(i, 11).Value
Cells(i - 1, 13).Value = (Cells(2, 17).Value + Cells(i - 1, 5).Value - Cells(i - 1, 12).Value - Cells(i - 1, 7).Value) / Cells(i - 1, 10).Value
Cells(i, 13).Value = (Cells(2, 17).Value + Cells(i, 5).Value - Cells(i, 12).Value - Cells(i, 7).Value) / Cells(i, 10).Value
cntr3 = cntr3 + 1
If cntr3 = 25 Then Exit For
Next i
cntr4 = 0
For d = 30 To (Cells(1, 7).Value + 4)
Cells(d, 2).Value = Cells(21, 17).Value * Cells(d, 8).Value + Cells(d, 3).Value - Cells(d, 4).Value
cntr4 = cntr4 + 1
If cntr4 = 25 Then Exit For
Next d
End Sub
As you can see, cells(10,17)(1,17)(25,17)(5,17)(17,17)(4,6)(11,17)(5,9)(1,7)(24,17)(5,10) are the cells on changing any of which the sub should run automatically.

The following should be able to solve your problem.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("INPUT RANGE")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' YOUR CODE GOES HERE
End If
End Sub
Just change the INPUT RANGE and input your code where I have marked.

Resources