Posts by KjBox
-
-
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
-
-
Try this
Code
Display MoreSub 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
-
-
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"
-
You're welcome
-
Change the code to
Code
Display MorePrivate 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
-
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
Display MorePrivate 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
The players will be colored and grouped whenever one of the option buttons is selected.
-
Try changing the code to this
Code
Display MoreSub 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
-
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?
-
You're welcome
-
Do you need the colour fill to be included or is that just for clarity of explanation?
-
Try this. It will add a new sheet to your workbook, name the new sheet "Extracted Data" and place the extracted data there.
Code
Display MoreSub 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
-
Attach your workbook, would be easier than trying to follow your explanation.
-
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?
-
You're welcome.
-
Your welcome. The Like button is the smiley face at the bottom right of the post.
-
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
Display MoreSub 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
-
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
Display MoreSub 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