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
Related
I am trying to sort an SAP pull that is around 100k lines long. The sort is taking 30 minutes to run. Can you please take a look at this and see if there is anyway I can streamline my sort?
Thanks!
'''
Sub Sort_CFG_InvOnHand_Tab()
Dim wb As Workbook
Dim Ws2 As Worksheet
Set wb = Workbooks("TTB - Inv on hand - CFG_CL")
Set Ws2 = wb.Worksheets("InvOnHand")
Ws2.Activate
Dim N As Long, i As Long
N = Cells(Rows.Count, "H").End(xlUp).Row
For i = N To 2 Step -1
If Cells(i, "V") = "0" And Cells(i, "X") = "0" Then
Cells(i, "V").EntireRow.Delete
End If
If Left(Cells(i, "H"), 2) = "AA" Or Left(Cells(i, "H"), 2) = "DM" Or Left(Cells(i, "H"), 2) = "MX" Or Left(Cells(i, "I"), 3) = "EFN" Then
Cells(i, "H").EntireRow.Delete
End If
Next i
N = Cells(Rows.Count, "U").End(xlUp).Row
Cells(N + 2, "U") = "Total"
Cells(N + 3, "U") = "Negative Inventory"
Cells(N + 4, "U") = "Updated Total"
Cells(N + 6, "U") = "Prior Month Ending"
Cells(N + 8, "U") = "Difference"
Cells(N + 2, "V").Formula = "=SUM(V2:V" & N & ")"
Cells(N + 3, "V").Formula = "=SUMIF(V2:V" & N & ",""<0"")"
Cells(N + 4, "V") = Cells(N + 1, "V") - Cells(N + 2, "V")
Cells(N + 2, "X").Formula = "=SUM(X2:X" & N & ")"
Cells(N + 3, "X").Formula = "=SUMIF(X2:X" & N & ",""<0"")"
Cells(N + 4, "V") = Cells(N + 1, "V") - Cells(N + 2, "V")
MsgBox ("Sort Complete")
End Sub
'''
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
I would like to ask how to shorten the code below? Have any other ways to achieve the same result?
Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) = "" Then
Exit For
End If
Next i
End Sub
Thank you!
Here's Dictionary based approach which should work for you.
Public Sub RearrangeData()
Dim objDic As Object
Dim varRng
Dim i As Long
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = LBound(varRng) To UBound(varRng)
If objDic.Exists(varRng(i, 1)) Then
objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
Else
objDic.Add varRng(i, 1), varRng(i, 2)
End If
Next i
Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
Set objDic = Nothing
End Sub
here's another dictionary approach (no reference adding required)
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long
data = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data)
.Item(data(i, 1)) = .Item(data(i, 1)) & "/" & data(i, 2)
Next
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1).ClearContents
i = 1
For Each key In .Keys
i = i + 1
Cells(i, 1) = key
Cells(i, 2) = Mid(.Item(key), 2)
Next
End With
End Sub
BTW, should you ever need to combine strings from more columns, you could use
Option Explicit
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long, iCol As Long
With Range("A1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
data = .Value
.ClearContents
End With
End With
With CreateObject("Scripting.Dictionary")
For iCol = 2 To UBound(data, 2)
For i = 1 To UBound(data)
.Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
Next
Range("A2").Resize(.Count) = Application.Transpose(.Keys)
Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
.RemoveAll
Next
End With
Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
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
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.