Posts by KjBox

**KjBox** · 2022-07-03T14:01:25+01:00

You're welcome

**KjBox** · 2022-07-03T11:15:27+01:00

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

**KjBox** · 2022-07-03T00:55:21+01:00

If all you "Price List" files are in a single folder, and no other files in that folder, then it would be possible write code to loop through all the files and reformat the Table as required.

**KjBox** · 2022-07-03T00:48:23+01:00

Try this

Code

Sub DupsToCols()
    Dim x, y, i&, ii&, iii&, iv&, v&, vi&
    
    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
        .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]_-"
        End With
    End With
    
End Sub

Display More

**KjBox** · Saturday, 11:03 pm

No file attached

**KjBox** · Saturday, 1:02 am

You have a "With" statement that has not been closed with an "End With" also a "For" statement that has not been closed with "Next"

**KjBox** · Saturday, 12:48 am

You're welcome

**KjBox** · Friday, 8:06 pm

Change the code to

Code

Private Sub ColorRows()
    Dim x, i&
    
    With Sheet2.[c2].Resize(49, 4)
        x = .Value
        For i = 2 To UBound(x, 1)
            If x(i, 4) Mod 2 = 0 Or x(i, 1) = vbNullString Then
                .Cells(i, 1).Resize(, 2).Interior.Color = RGB(255, 255, 153)
            Else
                .Cells(i, 1).Resize(, 2).Interior.Color = RGB(255, 255, 0)
            End If
        Next
    End With
    
End Sub

Display More

**KjBox** · Friday, 3:27 am

Try this.

First delete all the conditional formatting rules that color the rows.

Note this code is placed in the "Players" sheet object module and replaces your existing code there, you can delete the code you had in Module 1

Code

Private Sub OptionButton1_Click()
    If OptionButton1.Value = True Then Range("I1").Value = 4: ColorRows
End Sub

Private Sub OptionButton2_Click()
    If OptionButton2.Value = True Then Range("I1").Value = 3: ColorRows
End Sub

Private Sub ColorRows()
    Dim x, i&
    
    With Sheet2.[c2].CurrentRegion.Resize(, 4)
        x = .Value
        For i = 2 To UBound(x, 1)
            If x(i, 4) Mod 2 = 0 Or x(i, 1) = vbNullString Then
                .Cells(i, 1).Resize(, 2).Interior.Color = RGB(255, 255, 153)
            Else
                .Cells(i, 1).Resize(, 2).Interior.Color = RGB(255, 255, 0)
            End If
        Next
    End With
    
End Sub

Display More

The players will be colored and grouped whenever one of the option buttons is selected.

**KjBox** · Thursday, 6:27 pm

Try changing the code to this

Code

Sub SplitName()
    Dim x, y, yy, z, i&, ii&
    
    With ActiveSheet
        x = .Columns(1).SpecialCells(2)
        ReDim y(1 To UBound(x, 1) - 1, 1 To 1)
        ReDim yy(1 To UBound(x, 1) - 1, 1 To 2)
        For i = 2 To UBound(x, 1)
            z = Split(x(i, 1))
            If InStr(1, x(i, 1), "(") = 0 Then
                For ii = LBound(z) To UBound(z) - 2
                    If IsEmpty(y(i - 1, 1)) Then
                        y(i - 1, 1) = Trim(z(ii))
                    Else
                        y(i - 1, 1) = y(i - 1, 1) & " " & Trim(z(ii))
                    End If
                Next
                yy(i - 1, 1) = Trim(z(UBound(z) - 1)) & " " & Trim(z(UBound(z)))
            Else
                For ii = LBound(z) To UBound(z) - 3
                    If IsEmpty(y(i - 1, 1)) Then
                        y(i - 1, 1) = Trim(z(ii))
                    Else
                        y(i - 1, 1) = y(i - 1, 1) & " " & Trim(z(ii))
                    End If
                Next
                yy(i - 1, 1) = Trim(z(UBound(z) - 2)) & " " & Trim(z(UBound(z) - 1))
                yy(i - 1, 2) = Trim(z(UBound(z)))
            End If
        Next
        .[a2].Resize(UBound(y, 1)) = y
        .[b2].Resize(UBound(yy, 1), 2) = yy
        .Columns(2).Resize(, 2).AutoFit
        With .Cells(1).CurrentRegion.Offset(1).Resize(.Cells(1).CurrentRegion.Rows.Count - 1)
            .Columns(1).Copy
            .Resize(, 3).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            .Columns(3).SpecialCells(4).EntireRow.Interior.Color = xlNone
            .Columns(2).Font.Italic = 1
            .Borders.Weight = 2
        End With
        Application.Goto .[a1]
    End With
    
End Sub

Display More

**KjBox** · Thursday, 11:54 am

No problem, I am in Borneo so 7 hours ahead of you.

Can you explain the logic of why, in your sample, Arend, Gevlekte has a grey fill in the current configuration but no fill in the required result, is it a case of all rows that have an empty cell in Column C have no fill?

**KjBox** · Thursday, 11:46 am

You're welcome

**KjBox** · Wednesday, 11:09 pm

Do you need the colour fill to be included or is that just for clarity of explanation?

**KjBox** · Wednesday, 9:23 pm

Try this. It will add a new sheet to your workbook, name the new sheet "Extracted Data" and place the extracted data there.

Code

Sub Extract()
    Dim x, y, i&, ii&, ws As Worksheet
    
    x = Sheets("Sheet4").UsedRange.Columns(1)   'Change sheet name to suit
    ReDim y(1 To UBound(x, 1), 1 To 4)
    y(1, 1) = "Person": y(1, 2) = "Address": y(1, 3) = "Represent": y(1, 4) = "Address"
    ii = 1
    For i = 1 To UBound(x, 1)
        If x(i, 1) Like "*Person:*" Then
            ii = ii + 1
            y(ii, 1) = Replace(x(i, 1), "Person: ", "")
            Do Until x(i, 1) Like "*DECDENT*"
                If Len(x(i, 1)) Then
                    If x(i, 1) Like "*Adresa:*" Then
                        y(ii, 2) = Replace(x(i, 1), "Adresa: ", "")
                        i = i + 1
                        Do Until x(i, 1) = vbNullString
                            If Right(y(ii, 2), 1) = "," Then
                                y(ii, 2) = y(ii, 2) & " " & x(i, 1)
                            Else
                                y(ii, 2) = y(ii, 2) & ", " & x(i, 1)
                            End If
                            i = i + 1
                            If i >= UBound(x, 1) Then Exit Do
                        Loop
                    ElseIf x(i, 1) Like "*Represent*" Then
                        y(ii, 3) = Replace(x(i, 1), "Represent: ", "")
                    ElseIf x(i, 1) Like "*Address*" Then
                        y(ii, 4) = Replace(x(i, 1), "Address: ", "")
                        i = i + 1
                        Do Until x(i, 1) = vbNullString
                            y(ii, 4) = y(ii, 4) & ", " & x(i, 1)
                            i = i + 1
                            If i >= UBound(x, 1) Then Exit Do
                        Loop
                    End If
                End If
                i = i + 1
                If i >= UBound(x, 1) Then Exit Do
            Loop
        End If
    Next
    Set ws = Sheets.Add(, Sheets(Sheets.Count))
    With ws
        .Name = "Extracted Data"
        .[a1].Resize(UBound(y, 1), 4) = y
        .Columns(1).Resize(, 4).AutoFit
        .Activate
    End With
End Sub

Display More

**KjBox** · Tuesday, 7:40 pm

Attach your workbook, would be easier than trying to follow your explanation.

**KjBox** · Tuesday, 6:52 pm

When the code runs do you want it to replace any data on the "result" sheet (apart from the header row) or to add new data to any existing data?

**KjBox** · Jun 18th 2022

You're welcome.

**KjBox** · Jun 18th 2022

Your welcome. The Like button is the smiley face at the bottom right of the post.

**KjBox** · Jun 17th 2022

Try the attached. Click the button on sheet 1

Assumes that your list is in Column A and Row 1 is a header row.

Since the words in italics are the scientific name there should always be 2 words (or an initial then a word). The common name can be any number of words.

The code will also remove any superfluous spaces.

Code assigned to the button.

Code

Sub SplitName()
    Dim x, y, yy, z, i&, ii&
    
    With ActiveSheet
        x = .Columns(1).SpecialCells(2)
        ReDim y(1 To UBound(x, 1) - 1, 1 To 1)
        ReDim yy(1 To UBound(x, 1) - 1, 1 To 1)
        For i = 2 To UBound(x, 1)
            z = Split(x(i, 1))
            For ii = LBound(z) To UBound(z) - 2
                If IsEmpty(y(i - 1, 1)) Then
                    y(i - 1, 1) = Trim(z(ii))
                Else
                    y(i - 1, 1) = y(i - 1, 1) & " " & Trim(z(ii))
                End If
            Next
            yy(i - 1, 1) = Trim(z(UBound(z) - 1)) & " " & Trim(z(UBound(z)))
        Next
        .[a2].Resize(UBound(y, 1)) = y
        With .[b2].Resize(UBound(yy, 1))
            .Value = yy
            .Font.Italic = 1
        End With
        .Columns(2).Resize(, 2).AutoFit
    End With
    
End Sub

Display More

**KjBox** · Jun 17th 2022

Try this instead. You can add a call to this macro at the end of your Refresh code so that highlighting of duplicates is updated after a refresh.

Code

Sub DuplicateCheck()
    Dim x, y, i&
    
    Application.ScreenUpdating = 0
    With Sheets("Main Report")
        With .PivotTables(1).DataBodyRange
            x = .Columns(1): y = .Columns(2)
        End With
        For i = 1 To UBound(x, 1)
            If x(i, 1) = y(i, 1) Then
                If .Rows(i + 5).Hidden = 0 Then
                    .Cells(i + 5, 1).Resize(, 7).Interior.Color = vbRed
                End If
            ElseIf .Cells(i + 5, 1).Interior.ColorIndex = 3 Then
                .Cells(i + 5, 1).Resize(, 7).Interior.Color = xlNone
            End If
        Next
    End With

End Sub

Display More

Posts by KjBox

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

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

Select and Export All Rows Between Two Different Cell Names, Loop

VBA to Control Conditional Formatting

VBA to Control Conditional Formatting

VBA to Control Conditional Formatting

VBA CODE TO SELECT ALL ITALISIZED WORDS IN A STRING

VBA CODE TO SELECT ALL ITALISIZED WORDS IN A STRING

Extract data from specific strings column

VBA CODE TO SELECT ALL ITALISIZED WORDS IN A STRING

Extract data from specific strings column

Macro to refer to a spreadsheet for iF, Then conditions

Extract data from specific strings column

VBA - Highlight Entire Row - Based on Duplicate

VBA CODE TO SELECT ALL ITALISIZED WORDS IN A STRING

VBA CODE TO SELECT ALL ITALISIZED WORDS IN A STRING

VBA - Highlight Entire Row - Based on Duplicate