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.
Related
I have a Excel Table in which I'd like to add new line if condition meet. Actually my code is working partly. It adds lines but when the work finish Debug appears (Run-time error 13, type mismatch).
I am in trouble if sometimes unexpected error happens. So please help me make my code more advance and work properly.
Sub AddWorkingYearLine2()
Dim i As Long
With Worksheets("DB")
For i = Cells(Rows.Count, "A").End(xlUp).Row To 4 Step -1
'make sure it's not an "old entry"
If Cells(i, "A").Value2 <> Cells(i + 1, "A").Value2 Then
'if today occurs after "end date" then
If Range("D1") > CDate(Cells(i, "F").Value) And Len(Cells(i, "F").Value2) > 0 Then
'insert row
Rows(i + 1).Insert Shift:=xlShiftDown
'copy row down
'Rows(i + 1).Value = Rows(i).Value
'update dates
Cells(i + 1, "A").Value = Cells(i, "A").Value
Cells(i + 1, "B").Value = Cells(i, "B").Value
Cells(i + 1, "C").Value = Cells(i, "C").Value
Cells(i + 1, "D").Value = Cells(i, "D").Value
Cells(i + 1, "E").Value = Cells(i, "F").Value
Cells(i + 1, "F").Value = DateAdd("yyyy", 1, CDate(Cells(i + 1, "E").Value))
Cells(i + 1, "G").Value = Cells(i, "M").Value
Cells(i + 1, "H").Value = Cells(i, "H").Value
Cells(i + 1, "I").Value = Cells(i, "I").Value
Cells(i + 1, "J").Value = Cells(i, "J").Value
Application.CutCopyMode = False
End If
End If
Next i
End With
End Sub
you're using With Worksheets("DB") but then you're not referencing all range objects to Worksheets("DB") object since you're not using dots...
Dim i As Long
With Worksheets("DB")
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 4 Step -1
'make sure it's not an "old entry"
If .Cells(i, "A").Value2 <> .Cells(i + 1, "A").Value2 Then
'if today occurs after "end date" then
If .Range("D1") > CDate(.Cells(i, "F").Value) And Len(.Cells(i, "F").Value2) > 0 Then
'insert row
.Rows(i + 1).Insert Shift:=xlShiftDown
'copy row down
'Rows(i + 1).Value = Rows(i).Value
'update dates
.Cells(i + 1, "A").Value = .Cells(i, "A").Value
.Cells(i + 1, "B").Value = .Cells(i, "B").Value
.Cells(i + 1, "C").Value = .Cells(i, "C").Value
.Cells(i + 1, "D").Value = .Cells(i, "D").Value
.Cells(i + 1, "E").Value = .Cells(i, "F").Value
.Cells(i + 1, "F").Value = DateAdd("yyyy", 1, CDate(.Cells(i + 1, "E").Value))
.Cells(i + 1, "G").Value = .Cells(i, "M").Value
.Cells(i + 1, "H").Value = .Cells(i, "H").Value
.Cells(i + 1, "I").Value = .Cells(i, "I").Value
.Cells(i + 1, "J").Value = .Cells(i, "J").Value
Application.CutCopyMode = False
End If
End If
Next
End With
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
I have a code which Sheet "RAW" is updated each day with more rows and updates the existing rows, I'm trying to get the number in Column B to match Column A in sheet data, then depending on what information is in other columns add 1 to a value in a column (17 different options)
It's basically going to be used as a tracker to check how many days something is on a specific status and I need to keep it for historical Measuring indefintely. here is what I have so far which doesn't seem to work.
Additionally I would also like it to measure an 18th catagory if it is missing from the data list if this is possibble?
'status tracking
Sub Status_Track()
Dim a As Long 'topic number
Dim Z As Long
Dim R As Long
Dim i As Long
Dim S As Long
Dim D As Long
Worksheets("RAW").Activate
R = Cells(Rows.Count, 2).End(xlUp).Row
C = Cells(1, Columns.Count).End(xlToLeft).Column
Z = 0
i = 2
Do Until i > R
'ident
If Cells(i, 2) = Worksheets("Data").Cells(i, 1) And (Cells(i, 13) = "ERKA") Then
Z = Worksheets("Data").Cells(i, 6) + 1
Worksheets("Data").Cells(i, 6).Value = Z
ElseIf Cells(i, 2) = Worksheets("Data").Cells(i, 1) And (Cells(i, 13) = "INBA") Then
'Inba
Z = Worksheets("Data").Cells(i, 7) + 1
Worksheets("Data").Cells(i, 7).Value = Z
ElseIf Cells(i, 2) = Worksheets("Data").Cells(i, 1) And (Cells(i, 13) = "ABGE") Then
'Abge
Z = Worksheets("Data").Cells(i, 8) + 1
Worksheets("Data").Cells(i, 8).Value = Z
ElseIf Cells(i, 2) = Worksheets("Data").Cells(i, 1) And (Cells(i, 13) = "GELO") Then
'Gelo
Z = Worksheets("Data").Cells(i, 5) + 1
Worksheets("Data").Cells(i, 5).Value = Z
ElseIf Cells(i, 2) = Worksheets("Data").Cells(i, 1) And (Cells(i, 13) = "UEBE") And (Cells(i, 11) = 0) Then
'UEBE
Z = Worksheets("Data").Cells(i, 9) + 1
Worksheets("Data").Cells(i, 9).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "<1") Then
'1
Z = Worksheets("Data").Cells(i, 10) + 1
Worksheets("Data").Cells(i, 10).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "6") Then
'6
Z = Worksheets("Data").Cells(i, 11) + 1
Worksheets("Data").Cells(i, 11).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "9") Then
'9
Z = Worksheets("Data").Cells(i, 12) + 1
Worksheets("Data").Cells(i, 12).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "10") Then
'10
Z = Worksheets("Data").Cells(i, 13) + 1
Worksheets("Data").Cells(i, 13).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "15") Then
'15
Z = Worksheets("Data").Cells(i, 14) + 1
Worksheets("Data").Cells(i, 14).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "30") Then
'30
Z = Worksheets("Data").Cells(i, 15) + 1
Worksheets("Data").Cells(i, 15).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "50") Then
'50
Z = Worksheets("Data").Cells(i, 16) + 1
Worksheets("Data").Cells(i, 16).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "60") Then
'60
Z = Worksheets("Data").Cells(i, 17) + 1
Worksheets("Data").Cells(i, 17).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "70") Then
'70
Z = Worksheets("Data").Cells(i, 18) + 1
Worksheets("Data").Cells(i, 18).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "80") Then
'80
Z = Worksheets("Data").Cells(i, 19) + 1
Worksheets("Data").Cells(i, 19).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "90") Then
'90
Z = Worksheets("Data").Cells(i, 20) + 1
Worksheets("Data").Cells(i, 20).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "97") Then
'97
Z = Worksheets("Data").Cells(i, 21) + 1
Worksheets("Data").Cells(i, 21).Value = Z
ElseIf Cells(i, 11) = 1 And (Cells(i, 28) = "100") Then
'100
Z = Worksheets("Data").Cells(i, 22) + 1
Worksheets("Data").Cells(i, 22).Value = Z
End If
Loop
End Sub
It could look something like that to find the corresponding identifier
Option Explicit 'must be the first line in a module: forces you to declare any variables before use
'status tracking
Sub Status_Track_Extended()
Dim wsRaw As Worksheet, wsData As Worksheet
Set wsRaw = ThisWorkbook.Worksheets("RAW")
Set wsData = ThisWorkbook.Worksheets("Data")
Dim LastRow As Long
LastRow = wsRaw.Cells(wsRaw.Rows.Count, 2).End(xlUp).Row 'find last row in sheet RAW
Dim FoundCell As Range, FoundRow As Long
Dim DataCol As Long
Dim i As Long
For i = 2 To LastRow 'start at row 2 up to last used row
'find corresponding row by identifier (column 2) in sheet Data
Set FoundCell = wsData.Columns(1).Find(wsRaw.Cells(i, 2))
If Not FoundCell Is Nothing Then 'only do the follwing if the identifier was found in sheet Data
FoundRow = FoundCell.Row
'ident
If wsRaw.Cells(i, 13) = "ERKA" Then
wsData.Cells(FoundRow, 6).Value = wsData.Cells(FoundRow, 6).Value + 1
ElseIf wsRaw.Cells(i, 13) = "INBA" Then
'Inba
wsData.Cells(FoundRow, 7).Value = wsData.Cells(FoundRow, 7).Value + 1
ElseIf wsRaw.Cells(i, 13) = "ABGE" Then
'Abge
wsData.Cells(FoundRow, 8).Value = wsData.Cells(FoundRow, 8).Value + 1
ElseIf wsRaw.Cells(i, 13) = "GELO" Then
'Gelo
wsData.Cells(FoundRow, 5).Value = wsData.Cells(FoundRow, 5).Value + 1
ElseIf wsRaw.Cells(i, 13) = "UEBE" And wsRaw.Cells(i, 11) = 0 Then
'UEBE
wsData.Cells(FoundRow, 9).Value = wsData.Cells(FoundRow, 9).Value + 1
ElseIf wsRaw.Cells(i, 11) = 1 Then
Select Case wsRaw.Cells(i, 28)
Case "<1"
wsData.Cells(FoundRow, 10).Value = wsData.Cells(FoundRow, 10).Value + 1
Case "6"
wsData.Cells(FoundRow, 11).Value = wsData.Cells(FoundRow, 11).Value + 1
Case "9"
wsData.Cells(FoundRow, 12).Value = wsData.Cells(FoundRow, 12).Value + 1
Case "10"
wsData.Cells(FoundRow, 13).Value = wsData.Cells(FoundRow, 13).Value + 1
Case "15"
wsData.Cells(FoundRow, 14).Value = wsData.Cells(FoundRow, 14).Value + 1
Case "30"
wsData.Cells(FoundRow, 15).Value = wsData.Cells(FoundRow, 15).Value + 1
Case "50"
wsData.Cells(FoundRow, 16).Value = wsData.Cells(FoundRow, 16).Value + 1
Case "60"
wsData.Cells(FoundRow, 17).Value = wsData.Cells(FoundRow, 17).Value + 1
Case "70"
wsData.Cells(FoundRow, 18).Value = wsData.Cells(FoundRow, 18).Value + 1
Case "80"
wsData.Cells(FoundRow, 19).Value = wsData.Cells(FoundRow, 19).Value + 1
Case "90"
wsData.Cells(FoundRow, 20).Value = wsData.Cells(FoundRow, 20).Value + 1
Case "97"
wsData.Cells(FoundRow, 21).Value = wsData.Cells(FoundRow, 21).Value + 1
Case "100"
wsData.Cells(FoundRow, 22).Value = wsData.Cells(FoundRow, 22).Value + 1
End Select
End If
Else 'error if identifier was not found
MsgBox "Identifier '" & wsRaw.Cells(i, 2) & "' could not be found in sheet 'Data'.", vbExclamation + vbOKOnly
End If
Next i
End Sub
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
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