Posts by KjBox

**KjBox** · Monday, 7:30 pm

You're welcome

**KjBox** · Aug 6th 2022

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.

**KjBox** · Aug 6th 2022

So to get the Revised Quantity the Line Quantity of the last entry for each Item is reduced by the Required Quantity?

**KjBox** · Aug 5th 2022

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

Sub 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

Display More

**KjBox** · Aug 5th 2022

You're welcome

**KjBox** · Aug 5th 2022

OK I worked out the logic.

Try the attached file, click the button on the sheet.

Code assigned to the button:

Code

Sub 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

Display More

**KjBox** · Aug 5th 2022

What do you mean by

Quote from gentle_20052006

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?

**KjBox** · Jul 30th 2022

You're welcome

**KjBox** · Jul 29th 2022

Try the attached

Code assigned to the button

Code

Sub 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

Display More

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

Private 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

Display More

**KjBox** · Jul 28th 2022

Attach a workbook which has just the data you have in columns W, X & Y

**KjBox** · Jul 28th 2022

Try the following

First run this code with the sheet needing comments in Column I active

Code

Sub 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

Display More

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

Private 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

Display More

**KjBox** · Jul 27th 2022

Try this

Code

Sub NewNumber()
    Dim x, i&
    
    With ActiveSheet
        x = .Cells(1).CurrentRegion
        For i = 2 To UBound(x)
            If x(i, 1) > 1999 Then Exit For
        Next
        .Rows(i).Insert
        .Cells(i, 1) = x(i - 1, 1) + 1
    End With
    
End Sub

Display More

**KjBox** · Jul 27th 2022

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

**KjBox** · Jul 20th 2022

I can look at this for you

**KjBox** · Jul 7th 2022

You're welcome

**KjBox** · Jul 6th 2022

Probably because there is a Function Routine missing, named "Function WordNotOpen() As Boolean "

**KjBox** · Jul 4th 2022

You're welcome

**KjBox** · Jul 4th 2022

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

Sub 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

Display More

**KjBox** · Jul 3rd 2022

You're welcome

**KjBox** · Jul 3rd 2022

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

Sub 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

Display More

Posts by KjBox

Split values among relevant columns field

Split values among relevant columns field

Split values among relevant columns field

Split values among relevant columns field

Split values among relevant columns field

Split values among relevant columns field

Split values among relevant columns field

Adding Range of Cell Value to Comments

Adding Range of Cell Value to Comments

Adding Range of Cell Value to Comments

Adding Range of Cell Value to Comments

search a number and insert row

Macro works, then fails on second run, but if i click End and then run it again, it works again. WHY

HC_Trend_Automation - USD30

VBA CODE TO SELECT ALL ITALISIZED WORDS IN A STRING

Macro for filling in invoices with excel and word

If dupplicate values found in column A - copy/paste range B:D of the dupplicates on the same row of the original value

If dupplicate values found in column A - copy/paste range B:D of the dupplicates on the same row of the original value

If dupplicate values found in column A - copy/paste range B:D of the dupplicates on the same row of the original value

If dupplicate values found in column A - copy/paste range B:D of the dupplicates on the same row of the original value