You're welcome
Posts by KjBox
-
-
Probably easiest to do it with a formula, put this in E2 and copy down:
=IF($D3="","",IF(ROW(A3)<3,IF(IF(D3<>"-",B3-$D3,B3)<0,0,IF(D3<>"-",B3-D3,B3)),IF(AND(A3<>A2,A3=A4),IF(IF(D3<>"-",B3-D3,B3)<0,0,IF(D3<>"-",B3-$D3,B3)),IF(AND(A3=A2,A3=A4),IF(OR(E2=C2,E2=0),0,IF(IF(D3<>"-",B3-D3,B3)<0,0,IF(D3<>"-",B3-D3,B3))),IF(IF(D3<>"-",B3-D3,B3)<0,0,IF(D3<>"-",B3-D3,B3))))))
You will also need to make a small change to the VBA code.
Change With Sheet1.Cells(1).CurrentRegion to With Sheet1.Cells(1).CurrentRegion.Resize(, 4)
I am attaching the sample file with additional Items, Line Quantities and Gross Quantities so as to test for all possible scenarios. The Revised Line Quantity column has the above formula in it and the change to the code made, click the button as before.
-
So to get the Revised Quantity the Line Quantity of the last entry for each Item is reduced by the Required Quantity?
-
Just realised the code will fail if the Item in Column A is an Item with just a single row.
Change the code to what is shown below to overcome this.
Code
Display MoreSub RqdQty() Dim x, i&, ii&, iii& With Sheet1.Cells(1).CurrentRegion x = .Value For i = 2 To UBound(x, 1) ii = 0: iii = 0 If i < UBound(x, 1) Then If x(i, 1) = x(i + 1, 1) Then x(i, 4) = "-": ii = x(i, 2) Do Until x(i, 1) <> x(i + 1, 1) If x(i, 2) > x(i, 3) Then x(i, 4) = x(i, 2) - x(i, 3) ii = ii + x(i + 1, 2) iii = iii + x(i, 4) Else x(i, 4) = "-": ii = ii + x(i + 1, 2) End If i = i + 1 If i >= UBound(x, 1) Then Exit Do Loop If ii > x(i, 3) Then x(i, 4) = (ii - x(i, 3)) - iii Else x(i, 4) = "-" End If ElseIf x(i, 2) > x(i, 3) Then x(i, 4) = x(i, 2) - x(i, 3) Else x(i, 4) = "-" End If ElseIf x(i, 2) > x(i, 3) Then x(i, 4) = x(i, 2) - x(i, 3) Else x(i, 4) = "-" End If Next .Value = x .Columns(4).HorizontalAlignment = -4152 End With End Sub
-
You're welcome
-
OK I worked out the logic.
Try the attached file, click the button on the sheet.
Code assigned to the button:
Code
Display MoreSub RqdQty() Dim x, i&, ii&, iii& With Sheet1.Cells(1).CurrentRegion x = .Value For i = 2 To UBound(x, 1) ii = 0: iii = 0 If x(i, 1) = x(i + 1, 1) Then x(i, 4) = "-": ii = x(i, 2) Do Until x(i, 1) <> x(i + 1, 1) If x(i, 2) > x(i, 3) Then x(i, 4) = x(i, 2) - x(i, 3) ii = ii + x(i + 1, 2) iii = iii + x(i, 4) Else x(i, 4) = "-": ii = ii + x(i + 1, 2) End If i = i + 1 If i >= UBound(x, 1) Then Exit Do Loop If ii > x(i, 3) Then x(i, 4) = (ii - x(i, 3)) - iii Else x(i, 4) = "-" End If ElseIf x(i, 2) > x(i, 3) Then x(i, 4) = x(i, 2) - x(i, 3) Else x(i, 4) = "-" End If Next .Value = x End With End Sub
-
What do you mean by
I need it line wise
Are the values in Column D the required result? If so, then what is the logic to get those results?
-
You're welcome
-
Try the attached
Code assigned to the button
Code
Display MoreSub SetCellComments() Dim x, i& With ActiveSheet.ListObjects(1).DataBodyRange x = .Columns(23).Resize(, 3) .Columns(9).ClearComments For i = 1 To UBound(x, 1) With .Columns(9).Rows(i) If x(i, 1) <> "" And x(i, 2) <> "" And x(i, 3) <> "" Then .AddComment "Product ID: " & x(i, 1) & vbLf & _ "Product Amount: " & x(i, 2) & vbLf & _ "Product Paid Amount: " & x(i, 3) With .Comment.Shape.TextFrame .AutoSize = True .Characters.Font.Name = "Times New Roman" .Characters.Font.Size = 14 End With End If End With Next End With End Sub
Note this code needs to be run just once and can then be deleted. It will add the comments to all cells in the Table Column 9.
It will be faster than your code, but even if it takes a few seconds, or even minutes, to run it does not really matter as it never needs to be run again.
The code below is in the Sheet Object Module and will update the Column 9 comment for any change to Columns 23, 24 or 25
Code
Display MorePrivate Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, ActiveSheet.Cells(9, 23).Resize(1991, 3)) Is Nothing Then With ActiveSheet.Cells(Target.Row, 9) .ClearComments If .Parent.Cells(Target.Row, 23) <> "" _ And .Parent.Cells(Target.Row, 24) <> "" _ And .Parent.Cells(Target.Row, 25) <> "" Then .AddComment "Product ID: " & .Parent.Cells(Target.Row, 23) & vbLf & _ "Product Amount: " & .Parent.Cells(Target.Row, 24) & vbLf & _ "Product Amount Paid: " & .Parent.Cells(Target.Row, 25) With .Comment.Shape.TextFrame .AutoSize = True .Characters.Font.Name = "Times New Roman" .Characters.Font.Size = 14 End With End If End With End If End Sub
-
Attach a workbook which has just the data you have in columns W, X & Y
-
Try the following
First run this code with the sheet needing comments in Column I active
Code
Display MoreSub SetCellComments() Dim x, i& With ActiveSheet x = .Cells(9, 23).Resize(1191, 3) .Cells(9, 9).Resize(1191).ClearComments For i = 1 To UBound(x, 1) With .Cells(i + 8, 9) If Len(x(i, 1)) And Len(x(i, 2)) And Len(x(i, 3)) Then .AddComment "Product ID: " & x(i, 1) & vbLf & _ "Product Amount: " & x(i, 2) & vbLf & _ "Product Paid Amount: " & x(i, 1) End If End With Next End With End Sub
The above code needs to be run just once to initially add required comments, if any, to Column I
The code below will update the comment in Column I for any change in Columns W, X or Y in the same row.
Note this code must be placed in the Sheet Object Module not a standard module
Code
Display MorePrivate Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, ActiveSheet.Cells(9, 23).Resize(1191, 3)) Is Nothing Then With ActiveSheet.Cells(Target.Row, 9) .ClearComments If Len(.Parent.Cells(Target.Row, 23)) _ And Len(.Parent.Cells(Target.Row, 24)) _ And Len(.Parent.Cells(Target.Row, 25)) Then .AddComment "Product ID: " & .Parent.Cells(Target.Row, 23) & vbLf & _ "Product Amount: " & .Parent.Cells(Target.Row, 24) & vbLf & _ "Product Paid Amount: " & .Parent.Cells(Target.Row, 25) End If End With End If End Sub
-
-
PasteSpecial should be qualified with what should be pasted.
For example
PasteSpecial xlPasteValues
or
PasteSpecial xlPasteFormats
or
PasteSpecial xlPasteAll
See https://docs.microsoft.com/en-…/excel.range.pastespecial
-
I can look at this for you
-
You're welcome
-
Probably because there is a Function Routine missing, named "Function WordNotOpen() As Boolean "
-
-
The error is because the sheet code name was different ("Foglio2" instead of "Foglio1"). The code below will work with any sheet code name, but the sheet that needs to have duplicates put into columns must be the active sheet.
Note that the Table on the actual data example only allows for up to 4 duplicates so the previous error will occur if there are 5 duplicates.
Code
Display MoreSub DupsToCols() Dim x, y, i&, ii&, iii&, iv&, v&, vi& Application.ScreenUpdating = 0 With ActiveSheet.ListObjects(1).DataBodyRange x = .Value ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2)) For i = 1 To UBound(x, 1) vi = i For ii = 1 To 4 y(vi, ii) = x(i, ii) Next If x(i, 1) = x(i + 1, 1) Then i = i + 1: iii = 3: iv = 1 Do Until x(i, 1) <> x(i - 1, 1) v = iii * iv For ii = 2 To 4 y(vi, ii + v) = x(i, ii) Next i = i + 1: iv = iv + 1 If i > UBound(x, 1) Then Exit Do Loop i = i - 1 End If Next .Clear .Value = y End With With ActiveSheet.ListObjects(1) For i = UBound(x, 1) To 1 Step -1 If IsEmpty(y(i, 1)) Then .ListRows(i).Delete Next With .DataBodyRange .Columns(2).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(5).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(8).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(11).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(14).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" End With End With End Sub
-
-
You're welcome.
The reason for the error is that your Table allows for only up to 4 duplicates, add 3 columns to you table, "price-5", "from qty5" & "to qty5".
Also the formatting for "price-5" needs to be added to the code
Amended code
Code
Display MoreSub DupsToCols() Dim x, y, i&, ii&, iii&, iv&, v&, vi& Application.ScreenUpdating = 0 With Foglio1.ListObjects(1).DataBodyRange x = .Value ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2)) For i = 1 To UBound(x, 1) vi = i For ii = 1 To 4 y(vi, ii) = x(i, ii) Next If x(i, 1) = x(i + 1, 1) Then i = i + 1: iii = 3: iv = 1 Do Until x(i, 1) <> x(i - 1, 1) v = iii * iv For ii = 2 To 4 y(vi, ii + v) = x(i, ii) Next i = i + 1: iv = iv + 1 If i > UBound(x, 1) Then Exit Do Loop i = i - 1 End If Next .Clear .Value = y End With With Foglio1.ListObjects(1) For i = UBound(x, 1) To 1 Step -1 If IsEmpty(y(i, 1)) Then .ListRows(i).Delete Next With .DataBodyRange .Columns(2).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(5).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(8).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(11).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" .Columns(14).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;[email protected]_-" End With End With End Sub